module Data.Profunctor.Product.Class where

import           Data.Profunctor (Profunctor)
import qualified Data.Profunctor as Profunctor

--- vv These are redundant imports but they're needeed for Haddock
--- links. AIUI Haddock can't link to something you haven't imported.
--
--     https://github.com/haskell/haddock/issues/796
import qualified Control.Applicative
import qualified Data.Profunctor

-- | 'ProductProfunctor' is a generalization of
-- 'Control.Applicative.Applicative'.
-- It has the usual 'Control.Applicative.Applicative' "output"
-- (covariant) parameter on the right.  Additionally it has an "input"
-- (contravariant) type parameter on the left.
--
-- The methods for 'ProductProfunctor' correspond closely to those for
-- 'Control.Applicative.Applicative' as laid out in the following
-- table.
-- The only difference between them is that the 'ProductProfunctor'
-- has a contravariant type parameter on the left.  We can use the
-- contravariant to compose them in nice ways as described at
-- "Data.Profunctor.Product".
--
-- @
-- | Correspondence between Applicative and ProductProfunctor
-- |
-- |  'Control.Applicative.Applicative' f           'ProductProfunctor' p
-- |
-- |  'Control.Applicative.pure'                    'purePP'
-- |    :: b -> f b             :: b -> p a b
-- |
-- |  ('Control.Applicative.<$>')                   ('Data.Profunctor.Product.***$')
-- |    :: (b -> b')            :: (b -> b')
-- |    -> f b                  -> p a b
-- |    -> f b'                 -> p a b'
-- |
-- |  ('Control.Applicative.<*>')                   ('****')
-- |    :: f (b -> b')          :: p a (b -> b')
-- |    -> f b                  -> p a b
-- |    -> f b'                 -> p a b'
-- @
--
-- It's easy to make instances of 'ProductProfunctor'.  Just make
-- instances
--
-- @
--  instance 'Profunctor' MyProductProfunctor where
--    ...
--
--  instance 'Control.Applicative.Applicative' (MyProductProfunctor a) where
--    ...
-- @
--
-- and then write
--
-- @
--  instance 'ProductProfunctor' MyProductProfunctor where
--    'purePP' = 'Control.Applicative.pure'
--    ('****') = ('Control.Applicative.<*>')
-- @
class Profunctor p => ProductProfunctor p where
  -- | 'purePP' is the generalisation of @Applicative@'s
  -- 'Control.Applicative.pure'.
  --
  -- (You probably won't need to use this except to define
  -- 'ProductProfunctor' instances.  In your own code @pure@ should be
  -- sufficient.)
  purePP :: b -> p a b
  purePP b
b = (a -> ()) -> (() -> b) -> p () () -> p a b
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
Profunctor.dimap (() -> a -> ()
forall a b. a -> b -> a
const ()) (b -> () -> b
forall a b. a -> b -> a
const b
b) p () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty

  -- | '****' is the generalisation of @Applicative@'s
  -- 'Control.Applicative.<*>'.
  --
  -- (You probably won't need to use this except to define
  -- 'ProductProfunctor' instances.  In your own code @\<*\>@ should
  -- be sufficient.)
  (****) :: p a (b -> c) -> p a b -> p a c
  (****) p a (b -> c)
f p a b
x = (a -> (a, a))
-> ((b -> c, b) -> c) -> p (a, a) (b -> c, b) -> p a c
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
Profunctor.dimap a -> (a, a)
forall b. b -> (b, b)
dup (((b -> c) -> b -> c) -> (b -> c, b) -> c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (b -> c) -> b -> c
forall a b. (a -> b) -> a -> b
($)) (p a (b -> c)
f p a (b -> c) -> p a b -> p (a, a) (b -> c, b)
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! p a b
x)
    where dup :: b -> (b, b)
dup b
y = (b
y, b
y)

  -- | Use @pure ()@ instead.  @empty@ may be deprecated in a future
  -- version.
  empty  :: p () ()
  empty = () -> p () ()
forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
purePP ()

  -- | Use @\\f g -> (,) 'Control.Applicative.<$>'
  -- 'Data.Profunctor.lmap' fst f 'Control.Applicative.<*>'
  -- 'Data.Profunctor.lmap' snd g@ instead.
  -- @(***!)@ may be deprecated in a future version.
  (***!) :: p a b -> p a' b' -> p (a, a') (b, b')
  p a b
f ***! p a' b'
g = (,) (b -> b' -> (b, b')) -> p (a, a') b -> p (a, a') (b' -> (b, b'))
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
`Profunctor.rmap` ((a, a') -> a) -> p a b -> p (a, a') b
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
Profunctor.lmap (a, a') -> a
forall a b. (a, b) -> a
fst p a b
f
                  p (a, a') (b' -> (b, b')) -> p (a, a') b' -> p (a, a') (b, b')
forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** ((a, a') -> a') -> p a' b' -> p (a, a') b'
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
Profunctor.lmap (a, a') -> a'
forall a b. (a, b) -> b
snd p a' b'
g

class Profunctor p => SumProfunctor p where
  -- Morally we should have 'zero :: p Void Void' but I don't think
  -- that would actually be useful
  (+++!) :: p a b -> p a' b' -> p (Either a a') (Either b b')