{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Profunctor.Product (-- * @ProductProfunctor@
                                ProductProfunctor(..),
                                (***$),
                                -- * @SumProfunctor@
                                SumProfunctor(..),
                                list,
                                -- * @Newtype@
                                Newtype(..),
                                pNewtype,
                                -- * Deprecated versions
                                -- | Do not use.  Will be removed in a
                                -- future version.
                                defaultEmpty,
                                defaultProfunctorProduct,
                                defaultPoint,
                                -- * Re-exports
                                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)

-- ProductProfunctor and ProductContravariant are potentially
-- redundant type classes.  It seems to me that these are equivalent
-- to Profunctor with Applicative, and Contravariant with Monoid
-- respectively:
--
--    import Data.Profunctor
--    import Control.Applicative hiding (empty)
--    import Data.Functor.Contravariant
--    import Data.Monoid
--
--    empty :: (Applicative (p ())) => p () ()
--    empty = pure ()
--
--    (***!) :: (Applicative (p (a, a')), Profunctor p) =>
--                p a b -> p a' b' -> p (a, a') (b, b')
--    p ***! p' = (,) <$> lmap fst p <*> lmap snd p'
--
--    point :: Monoid (f ()) => f ()
--    point = mempty
--
--    (***<) :: (Monoid (f (a, b)), Contravariant f) =>
--                f a -> f b -> f (a, b)
--    p ***< p' = contramap fst p <> contramap snd p'
--
--
-- The only thing that makes me think that they are not *completely*
-- redundant is that (***!) and (***<) have to be defined
-- polymorphically in the type arguments, whereas if we took the
-- Profunctor+Applicative or Contravariant+Monoid approach we do not
-- have a guarantee that these operations are polymorphic.
--
-- Previously I wanted to replace ProductProfunctor and
-- ProductContravariant entirely.  This proved difficult as it is not
-- possible to expand the class constraints to require Applicative and
-- Monoid respectively.  We can't enforce a constraint 'Applicative (p
-- a)' where 'a' does not appear in the head.  This seems closely
-- related to the above issue of adhoc implementations.
--
-- There is a potential method of working around this issue using the
-- 'constraints' package:
-- stackoverflow.com/questions/12718268/polymorphic-constraint/12718620
--
-- Still, at least we now have default implementations of the class
-- methods, which makes things simpler.

-- | '***$' is the generalisation of 'Functor''s @\<$\>@.
--
-- '***$' = 'Profunctor.rmap', just like '<$>' = 'fmap'.
--
-- (You probably won't need to use this.  @\<$\>@ should be
-- sufficient.)
--
-- /Since 0.11.1.0:/ Generalised to work on arbitrary 'Profunctor's.
(***$) :: 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
(<*>)

-- | @since 0.11.1.0
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

-- { Sum

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)

-- | @since 0.11.1.0
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

-- | A generalisation of @map :: (a -> b) -> [a] -> [b]@.  It is also,
-- in spirit, a generalisation of @traverse :: (a -> f b) -> [a] -> f
-- [b]@, but the types need to be shuffled around a bit to make that
-- work.
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)

-- SumContravariant would be 'Data.Functor.Contravariant.Decidable'
-- (without the requirement to also be Divisible).

-- }

pTns [0..maxTupleSize]

pNs [0..maxTupleSize]

-- { Deprecated stuff

{-# DEPRECATED defaultEmpty "Use pure () instead" #-}
defaultEmpty :: Applicative (p ()) => p () ()
defaultEmpty :: forall (p :: * -> * -> *). Applicative (p ()) => p () ()
defaultEmpty = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-# DEPRECATED defaultProfunctorProduct "Use \\p p' -> liftA2 (,) (lmap fst p) (lmap snd p') instead" #-}
defaultProfunctorProduct :: (Applicative (p (a, a')), Profunctor p)
                         => p a b -> p a' b' -> p (a, a') (b, b')
defaultProfunctorProduct :: forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
defaultProfunctorProduct p a b
p p a' b'
p' = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall a b. (a, b) -> a
fst p a b
p) (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall a b. (a, b) -> b
snd p a' b'
p')

{-# DEPRECATED defaultPoint "Use mempty instead" #-}
defaultPoint :: Monoid (p ()) => p ()
defaultPoint :: forall (p :: * -> *). Monoid (p ()) => p ()
defaultPoint = forall a. Monoid a => a
mempty

-- }