{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Profunctor.Product (
ProductProfunctor(..),
(***$),
SumProfunctor(..),
list,
Newtype(..),
pNewtype,
defaultEmpty,
defaultProfunctorProduct,
defaultPoint,
module Data.Profunctor.Product.Class,
module Data.Profunctor.Product) where
import Prelude hiding (id)
import Data.Profunctor (Profunctor, lmap, WrappedArrow, Star(Star), Costar, Forget(Forget))
import qualified Data.Profunctor as Profunctor
import Data.Profunctor.Composition (Procompose(..))
import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable, chosen)
import Control.Category (id)
import Control.Arrow (Arrow, (***), ArrowChoice, (+++))
import Control.Applicative (Applicative, liftA2, pure, (<*>), Alternative, (<|>), (<$>))
import Data.Monoid (Monoid, mempty)
import Data.Tagged
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Joker
import Data.Bifunctor.Product
import Data.Bifunctor.Tannen
import Data.Profunctor.Product.Newtype
import Data.Profunctor.Product.Class
import Data.Profunctor.Product.Flatten
import Data.Profunctor.Product.Tuples
import Data.Profunctor.Product.Tuples.TH (pTns, maxTupleSize, pNs)
(***$) :: Profunctor p => (b -> c) -> p a b -> p a c
***$ :: forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
(***$) = forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
Profunctor.rmap
instance ProductProfunctor (->) where
purePP :: forall b a. b -> a -> b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a b c. (a -> (b -> c)) -> (a -> b) -> a -> c
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Arrow arr => ProductProfunctor (WrappedArrow arr) where
empty :: WrappedArrow arr () ()
empty = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
***! :: forall a b a' b'.
WrappedArrow arr a b
-> WrappedArrow arr a' b' -> WrappedArrow arr (a, a') (b, b')
(***!) = forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***)
instance ProductProfunctor Tagged where
purePP :: forall b a. b -> Tagged a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a b c. Tagged a (b -> c) -> Tagged a b -> Tagged a c
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Applicative f => ProductProfunctor (Star f) where
purePP :: forall b a. b -> Star f a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a b c. Star f a (b -> c) -> Star f a b -> Star f a c
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Functor f => ProductProfunctor (Costar f) where
purePP :: forall b a. b -> Costar f a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a b c. Costar f a (b -> c) -> Costar f a b -> Costar f a c
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Monoid r => ProductProfunctor (Forget r) where
purePP :: forall b a. b -> Forget r a b
purePP b
_ = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget (forall b a. b -> a -> b
const forall a. Monoid a => a
mempty)
Forget a -> r
f ***! :: forall a b a' b'.
Forget r a b -> Forget r a' b' -> Forget r (a, a') (b, b')
***! Forget a' -> r
g = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget forall a b. (a -> b) -> a -> b
$ \(a
a, a'
a') -> a -> r
f a
a forall a. Semigroup a => a -> a -> a
<> a' -> r
g a'
a'
instance (ProductProfunctor p, ProductProfunctor q) => ProductProfunctor (Procompose p q) where
purePP :: forall b a. b -> Procompose p q a b
purePP b
a = forall {k} {k1} {k2} (p :: k -> k1 -> *) (x :: k) (c :: k1)
(q :: k2 -> k -> *) (d :: k2).
p x c -> q d x -> Procompose p q d c
Procompose (forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP b
a) (forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP ())
Procompose p x (b -> c)
pf q a x
qf **** :: forall a b c.
Procompose p q a (b -> c)
-> Procompose p q a b -> Procompose p q a c
**** Procompose p x b
pa q a x
qa =
forall {k} {k1} {k2} (p :: k -> k1 -> *) (x :: k) (c :: k1)
(q :: k2 -> k -> *) (d :: k2).
p x c -> q d x -> Procompose p q d c
Procompose (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall a b. (a, b) -> a
fst p x (b -> c)
pf forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall a b. (a, b) -> b
snd p x b
pa) ((,) forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
***$ q a x
qf forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** q a x
qa)
instance (Functor f, Applicative g, ProductProfunctor p) => ProductProfunctor (Biff p f g) where
purePP :: forall b a. b -> Biff p f g a b
purePP = forall {k} {k1} {k2} {k3} (p :: k -> k1 -> *) (f :: k2 -> k)
(g :: k3 -> k1) (a :: k2) (b :: k3).
p (f a) (g b) -> Biff p f g a b
Biff forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
Biff p (f a) (g (b -> c))
abc **** :: forall a b c.
Biff p f g a (b -> c) -> Biff p f g a b -> Biff p f g a c
**** Biff p (f a) (g b)
ab = forall {k} {k1} {k2} {k3} (p :: k -> k1 -> *) (f :: k2 -> k)
(g :: k3 -> k1) (a :: k2) (b :: k3).
p (f a) (g b) -> Biff p f g a b
Biff forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
***$ p (f a) (g (b -> c))
abc forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** p (f a) (g b)
ab
instance Applicative f => ProductProfunctor (Joker f) where
purePP :: forall b a. b -> Joker f a b
purePP = forall {k} {k1} (g :: k -> *) (a :: k1) (b :: k).
g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
Joker f (b -> c)
bc **** :: forall a b c. Joker f a (b -> c) -> Joker f a b -> Joker f a c
**** Joker f b
b = forall {k} {k1} (g :: k -> *) (a :: k1) (b :: k).
g b -> Joker g a b
Joker forall a b. (a -> b) -> a -> b
$ f (b -> c)
bc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f b
b
instance Divisible f => ProductProfunctor (Clown f) where
purePP :: forall b a. b -> Clown f a b
purePP b
_ = forall {k} {k1} (f :: k -> *) (a :: k) (b :: k1).
f a -> Clown f a b
Clown forall (f :: * -> *) a. Divisible f => f a
conquer
Clown f a
l **** :: forall a b c. Clown f a (b -> c) -> Clown f a b -> Clown f a c
**** Clown f a
r = forall {k} {k1} (f :: k -> *) (a :: k) (b :: k1).
f a -> Clown f a b
Clown forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\a
a -> (a
a, a
a)) f a
l f a
r
instance (ProductProfunctor p, ProductProfunctor q) => ProductProfunctor (Product p q) where
purePP :: forall b a. b -> Product p q a b
purePP b
a = forall {k} {k1} (f :: k -> k1 -> *) (g :: k -> k1 -> *) (a :: k)
(b :: k1).
f a b -> g a b -> Product f g a b
Pair (forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP b
a) (forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP b
a)
Pair p a (b -> c)
l1 q a (b -> c)
l2 **** :: forall a b c.
Product p q a (b -> c) -> Product p q a b -> Product p q a c
**** Pair p a b
r1 q a b
r2 = forall {k} {k1} (f :: k -> k1 -> *) (g :: k -> k1 -> *) (a :: k)
(b :: k1).
f a b -> g a b -> Product f g a b
Pair (p a (b -> c)
l1 forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** p a b
r1) (q a (b -> c)
l2 forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** q a b
r2)
instance (Applicative f, ProductProfunctor p) => ProductProfunctor (Tannen f p) where
purePP :: forall b a. b -> Tannen f p a b
purePP = forall {k} {k1} {k2} (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
(b :: k2).
f (p a b) -> Tannen f p a b
Tannen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP
Tannen f (p a (b -> c))
f **** :: forall a b c.
Tannen f p a (b -> c) -> Tannen f p a b -> Tannen f p a c
**** Tannen f (p a b)
a = forall {k} {k1} {k2} (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
(b :: k2).
f (p a b) -> Tannen f p a b
Tannen forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
(****) f (p a (b -> c))
f f (p a b)
a
instance SumProfunctor (->) where
a -> b
f +++! :: forall a b a' b'.
(a -> b) -> (a' -> b') -> Either a a' -> Either b b'
+++! a' -> b'
g = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> b'
g)
instance ArrowChoice arr => SumProfunctor (WrappedArrow arr) where
+++! :: forall a b a' b'.
WrappedArrow arr a b
-> WrappedArrow arr a' b'
-> WrappedArrow arr (Either a a') (Either b b')
(+++!) = forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
(+++)
instance Applicative f => SumProfunctor (Star f) where
Star a -> f b
f +++! :: forall a b a' b'.
Star f a b -> Star f a' b' -> Star f (Either a a') (Either b b')
+++! Star a' -> f b'
g = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> f b'
g)
instance SumProfunctor (Forget r) where
Forget a -> r
f +++! :: forall a b a' b'.
Forget r a b
-> Forget r a' b' -> Forget r (Either a a') (Either b b')
+++! Forget a' -> r
g = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> r
f a' -> r
g
instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Procompose p q) where
Procompose p x b
pa q a x
qa +++! :: forall a b a' b'.
Procompose p q a b
-> Procompose p q a' b'
-> Procompose p q (Either a a') (Either b b')
+++! Procompose p x b'
pb q a' x
qb = forall {k} {k1} {k2} (p :: k -> k1 -> *) (x :: k) (c :: k1)
(q :: k2 -> k -> *) (d :: k2).
p x c -> q d x -> Procompose p q d c
Procompose (p x b
pa forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! p x b'
pb) (q a x
qa forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! q a' x
qb)
instance Alternative f => SumProfunctor (Joker f) where
Joker f b
f +++! :: forall a b a' b'.
Joker f a b -> Joker f a' b' -> Joker f (Either a a') (Either b b')
+++! Joker f b'
g = forall {k} {k1} (g :: k -> *) (a :: k1) (b :: k).
g b -> Joker g a b
Joker forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
f forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b'
g
instance Decidable f => SumProfunctor (Clown f) where
Clown f a
f +++! :: forall a b a' b'.
Clown f a b -> Clown f a' b' -> Clown f (Either a a') (Either b b')
+++! Clown f a'
g = forall {k} {k1} (f :: k -> *) (a :: k) (b :: k1).
f a -> Clown f a b
Clown forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b c.
Decidable f =>
f b -> f c -> f (Either b c)
chosen f a
f f a'
g
instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Product p q) where
Pair p a b
l1 q a b
l2 +++! :: forall a b a' b'.
Product p q a b
-> Product p q a' b' -> Product p q (Either a a') (Either b b')
+++! Pair p a' b'
r1 q a' b'
r2 = forall {k} {k1} (f :: k -> k1 -> *) (g :: k -> k1 -> *) (a :: k)
(b :: k1).
f a b -> g a b -> Product f g a b
Pair (p a b
l1 forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! p a' b'
r1) (q a b
l2 forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! q a' b'
r2)
instance (Applicative f, SumProfunctor p) => SumProfunctor (Tannen f p) where
Tannen f (p a b)
l +++! :: forall a b a' b'.
Tannen f p a b
-> Tannen f p a' b' -> Tannen f p (Either a a') (Either b b')
+++! Tannen f (p a' b')
r = forall {k} {k1} {k2} (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
(b :: k2).
f (p a b) -> Tannen f p a b
Tannen forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
(+++!) f (p a b)
l f (p a' b')
r
list :: (ProductProfunctor p, SumProfunctor p) => p a b -> p [a] [b]
list :: forall (p :: * -> * -> *) a b.
(ProductProfunctor p, SumProfunctor p) =>
p a b -> p [a] [b]
list p a b
p = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
Profunctor.dimap forall a. [a] -> Either () (a, [a])
fromList forall a. Either () (a, [a]) -> [a]
toList (forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! (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 :: * -> * -> *) a b.
(ProductProfunctor p, SumProfunctor p) =>
p a b -> p [a] [b]
list p a b
p))
where toList :: Either () (a, [a]) -> [a]
toList :: forall a. Either () (a, [a]) -> [a]
toList = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall b a. b -> a -> b
const []) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:))
fromList :: [a] -> Either () (a, [a])
fromList :: forall a. [a] -> Either () (a, [a])
fromList [] = forall a b. a -> Either a b
Left ()
fromList (a
a:[a]
as) = forall a b. b -> Either a b
Right (a
a, [a]
as)