{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}

-- | This module provides profunctor classes and instances.
--
-- Please import this module qualified.
--
-- Some of the definitions in this module are heavily connected to and
-- motivated by linear optics. Please see @Control.Optics.Linear@ and other
-- optics modules for motivations for the definitions provided here.
--
-- == Connections to Linear Optics
--
-- * @Strong@ and @Wandering@ are classes drawn from
-- [this paper](https://www.cs.ox.ac.uk/jeremy.gibbons/publications/proyo.pdf)
-- * 'Exchange' and 'Market' are ways of encoding isomorphisms and prisms
--
module Data.Profunctor.Linear
  ( Profunctor(..)
  , Monoidal(..)
  , Strong(..)
  , Wandering(..)
  , LinearArrow(..), getLA
  , Exchange(..)
  , Market(..), runMarket
  ) where

import qualified Control.Functor.Linear as Control
import Data.Bifunctor.Linear hiding (first, second)
import qualified Data.Bifunctor as Prelude
import Data.Functor.Identity
import Prelude.Linear
import Prelude.Linear.Internal (runIdentity')
import Data.Kind (Type)
import Data.Void
import qualified Prelude
import Control.Arrow (Kleisli(..))


-- | A Profunctor can be thought of as a computation that involves taking
-- @a@(s) as input and returning @b@(s). These computations compose with
-- (linear) functions. Profunctors generalize the function arrow @->@.
--
-- Hence, think of a value of type @x `arr` y@ for profunctor @arr@ to be
-- something like a function from @x@ to @y@.
--
-- Laws:
--
-- > lmap id = id
-- > lmap (f . g) = lmap f . lmap g
-- > rmap id = id
-- > rmap (f . g) = rmap f . rmap g
--
class Profunctor (arr :: Type -> Type -> Type) where
  {-# MINIMAL dimap | lmap, rmap #-}

  dimap :: (s %1-> a) -> (b %1-> t) -> a `arr` b -> s `arr` t
  dimap s %1 -> a
f b %1 -> t
g arr a b
x = (s %1 -> a) -> arr a t -> arr s t
forall (arr :: * -> * -> *) s a t.
Profunctor arr =>
(s %1 -> a) -> arr a t -> arr s t
lmap s %1 -> a
f ((b %1 -> t) -> arr a b -> arr a t
forall (arr :: * -> * -> *) b t s.
Profunctor arr =>
(b %1 -> t) -> arr s b -> arr s t
rmap b %1 -> t
g arr a b
x)
  {-# INLINE dimap #-}

  lmap :: (s %1-> a) -> a `arr` t -> s `arr` t
  lmap s %1 -> a
f = (s %1 -> a) -> (t %1 -> t) -> arr a t -> arr s t
forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap s %1 -> a
f t %1 -> t
forall a. a %1 -> a
id
  {-# INLINE lmap #-}

  rmap :: (b %1-> t) -> s `arr` b -> s `arr` t
  rmap = (s %1 -> s) -> (b %1 -> t) -> arr s b -> arr s t
forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap s %1 -> s
forall a. a %1 -> a
id
  {-# INLINE rmap #-}

-- | A @(Monoidal m u arr)@ is a profunctor @arr@ that can be sequenced
-- with the bifunctor @m@. In rough terms, you can combine two function-like
-- things to one function-like thing that holds both input and output types
-- with the bifunctor @m@.
class (SymmetricMonoidal m u, Profunctor arr) => Monoidal m u arr where
  (***) :: a `arr` b -> x `arr` y -> (a `m` x) `arr` (b `m` y)
  unit :: u `arr` u

-- | A @(Strong m u arr)@ instance means that the function-like thing
-- of type @a `arr` b@ can be extended to pass along a value of type @c@
-- as a constant via the bifunctor of type @m@.
--
-- This typeclass is used primarily to generalize common patterns
-- and instances that are defined when defining optics. The two uses
-- below are used in defining lenses and prisms respectively in
-- "Control.Optics.Linear.Internal":
--
-- If @m@ is the tuple
-- type constructor @(,)@ then we can create a function-like thing
-- of type @(a,c) `arr` (b,c)@ passing along @c@ as a constant.
--
-- If @m@ is @Either@ then we can create a function-like thing of type
-- @Either a c `arr` Either b c@ that either does the original function
-- or behaves like the constant function.
class (SymmetricMonoidal m u, Profunctor arr) => Strong m u arr where
  {-# MINIMAL first | second #-}

  first :: a `arr` b -> (a `m` c) `arr` (b `m` c)
  first arr a b
arr = (m a c %1 -> m c a)
-> (m c b %1 -> m b c)
-> arr (m c a) (m c b)
-> arr (m a c) (m b c)
forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap m a c %1 -> m c a
forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap m c b %1 -> m b c
forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap (arr a b -> arr (m c a) (m c b)
forall (m :: * -> * -> *) u (arr :: * -> * -> *) b c a.
Strong m u arr =>
arr b c -> arr (m a b) (m a c)
second arr a b
arr)
  {-# INLINE first #-}

  second :: b `arr` c -> (a `m` b) `arr` (a `m` c)
  second arr b c
arr = (m a b %1 -> m b a)
-> (m c a %1 -> m a c)
-> arr (m b a) (m c a)
-> arr (m a b) (m a c)
forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap m a b %1 -> m b a
forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap m c a %1 -> m a c
forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap (arr b c -> arr (m b a) (m c a)
forall (m :: * -> * -> *) u (arr :: * -> * -> *) a b c.
Strong m u arr =>
arr a b -> arr (m a c) (m b c)
first arr b c
arr)
  {-# INLINE second #-}

-- | A @Wandering arr@ instance means that there is a @wander@ function
-- which is the traversable generalization of the classic lens function:
--
-- > forall f. Functor f => (a -> f b) -> (s -> f t)
--
-- in our notation:
--
-- > forall arr. (HasKleisliFunctor arr) => (a `arr` b) -> (s `arr` t)
--
-- @wander@ specializes the @Functor@ constraint to a control applicative:
--
-- > forall f. Applicative f => (a -> f b) -> (s -> f t)
-- > forall arr. (HasKleisliApplicative arr) => (a `arr` b) -> (s `arr` t)
--
-- where @HasKleisliFunctor@ or @HasKleisliApplicative@ are some constraints
-- which allow for the @arr@ to be @Kleisli f@ for control functors
-- or applicatives @f@.
--
class (Strong (,) () arr, Strong Either Void arr) => Wandering arr where
  -- | Equivalently but less efficient in general:
  --
  -- > wander :: Data.Traversable f => a `arr` b -> f a `arr` f b
  wander :: forall s t a b. (forall f. Control.Applicative f => (a %1-> f b) -> s %1-> f t) -> a `arr` b -> s `arr` t

---------------
-- Instances --
---------------

-- | This newtype is needed to implement 'Profunctor' instances of @#->@.
newtype LinearArrow a b = LA (a %1-> b)

-- | Temporary deconstructor since inference doesn't get it right
getLA :: LinearArrow a b %1-> a %1-> b
getLA :: forall a b. LinearArrow a b %1 -> a %1 -> b
getLA (LA a %1 -> b
f) = a %1 -> b
f

instance Profunctor LinearArrow where
  dimap :: forall s a b t.
(s %1 -> a) -> (b %1 -> t) -> LinearArrow a b -> LinearArrow s t
dimap s %1 -> a
f b %1 -> t
g (LA a %1 -> b
h) = (s %1 -> t) %1 -> LinearArrow s t
forall a b. (a %1 -> b) -> LinearArrow a b
LA ((s %1 -> t) %1 -> LinearArrow s t)
%1 -> (s %1 -> t) %1 -> LinearArrow s t
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ b %1 -> t
g (b %1 -> t) %1 -> (a %1 -> b) %1 -> a %1 -> t
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. a %1 -> b
h (a %1 -> t) %1 -> (s %1 -> a) %1 -> s %1 -> t
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. s %1 -> a
f

instance Strong (,) () LinearArrow where
  first :: forall a b c. LinearArrow a b -> LinearArrow (a, c) (b, c)
first  (LA a %1 -> b
f) = ((a, c) %1 -> (b, c)) %1 -> LinearArrow (a, c) (b, c)
forall a b. (a %1 -> b) -> LinearArrow a b
LA (((a, c) %1 -> (b, c)) %1 -> LinearArrow (a, c) (b, c))
%1 -> ((a, c) %1 -> (b, c)) %1 -> LinearArrow (a, c) (b, c)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \(a
a,c
b) -> (a %1 -> b
f a
a, c
b)
  second :: forall b c a. LinearArrow b c -> LinearArrow (a, b) (a, c)
second (LA b %1 -> c
g) = ((a, b) %1 -> (a, c)) %1 -> LinearArrow (a, b) (a, c)
forall a b. (a %1 -> b) -> LinearArrow a b
LA (((a, b) %1 -> (a, c)) %1 -> LinearArrow (a, b) (a, c))
%1 -> ((a, b) %1 -> (a, c)) %1 -> LinearArrow (a, b) (a, c)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \(a
a,b
b) -> (a
a, b %1 -> c
g b
b)

instance Strong Either Void LinearArrow where
  first :: forall a b c.
LinearArrow a b -> LinearArrow (Either a c) (Either b c)
first  (LA a %1 -> b
f) = (Either a c %1 -> Either b c)
%1 -> LinearArrow (Either a c) (Either b c)
forall a b. (a %1 -> b) -> LinearArrow a b
LA ((Either a c %1 -> Either b c)
 %1 -> LinearArrow (Either a c) (Either b c))
%1 -> (Either a c %1 -> Either b c)
%1 -> LinearArrow (Either a c) (Either b c)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ (a %1 -> Either b c)
-> (c %1 -> Either b c) -> Either a c %1 -> Either b c
forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (b %1 -> Either b c
forall a b. a -> Either a b
Left (b %1 -> Either b c) %1 -> (a %1 -> b) %1 -> a %1 -> Either b c
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. a %1 -> b
f) c %1 -> Either b c
forall a b. b -> Either a b
Right
  second :: forall b c a.
LinearArrow b c -> LinearArrow (Either a b) (Either a c)
second (LA b %1 -> c
g) = (Either a b %1 -> Either a c)
%1 -> LinearArrow (Either a b) (Either a c)
forall a b. (a %1 -> b) -> LinearArrow a b
LA ((Either a b %1 -> Either a c)
 %1 -> LinearArrow (Either a b) (Either a c))
%1 -> (Either a b %1 -> Either a c)
%1 -> LinearArrow (Either a b) (Either a c)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ (a %1 -> Either a c)
-> (b %1 -> Either a c) -> Either a b %1 -> Either a c
forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either a %1 -> Either a c
forall a b. a -> Either a b
Left (c %1 -> Either a c
forall a b. b -> Either a b
Right (c %1 -> Either a c) %1 -> (b %1 -> c) %1 -> b %1 -> Either a c
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. b %1 -> c
g)

instance Wandering LinearArrow where
  wander :: forall s t a b.
(forall (f :: * -> *).
 Applicative f =>
 (a %1 -> f b) -> s %1 -> f t)
-> LinearArrow a b -> LinearArrow s t
wander forall (f :: * -> *). Applicative f => (a %1 -> f b) -> s %1 -> f t
f (LA a %1 -> b
a_to_b) = (s %1 -> t) %1 -> LinearArrow s t
forall a b. (a %1 -> b) -> LinearArrow a b
LA ((s %1 -> t) %1 -> LinearArrow s t)
%1 -> (s %1 -> t) %1 -> LinearArrow s t
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \s
s -> Identity t %1 -> t
forall a. Identity a %1 -> a
runIdentity' (Identity t %1 -> t) %1 -> Identity t %1 -> t
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ (a %1 -> Identity b) -> s %1 -> Identity t
forall (f :: * -> *). Applicative f => (a %1 -> f b) -> s %1 -> f t
f (b %1 -> Identity b
forall a. a -> Identity a
Identity (b %1 -> Identity b) %1 -> (a %1 -> b) %1 -> a %1 -> Identity b
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. a %1 -> b
a_to_b) s
s

instance Monoidal (,) () LinearArrow where
  LA a %1 -> b
f *** :: forall a b x y.
LinearArrow a b -> LinearArrow x y -> LinearArrow (a, x) (b, y)
*** LA x %1 -> y
g = ((a, x) %1 -> (b, y)) %1 -> LinearArrow (a, x) (b, y)
forall a b. (a %1 -> b) -> LinearArrow a b
LA (((a, x) %1 -> (b, y)) %1 -> LinearArrow (a, x) (b, y))
%1 -> ((a, x) %1 -> (b, y)) %1 -> LinearArrow (a, x) (b, y)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \(a
a,x
x) -> (a %1 -> b
f a
a, x %1 -> y
g x
x)
  unit :: LinearArrow () ()
unit = (() %1 -> ()) -> LinearArrow () ()
forall a b. (a %1 -> b) -> LinearArrow a b
LA () %1 -> ()
forall a. a %1 -> a
id

instance Monoidal Either Void LinearArrow where
  LA a %1 -> b
f *** :: forall a b x y.
LinearArrow a b
-> LinearArrow x y -> LinearArrow (Either a x) (Either b y)
*** LA x %1 -> y
g = (Either a x %1 -> Either b y)
%1 -> LinearArrow (Either a x) (Either b y)
forall a b. (a %1 -> b) -> LinearArrow a b
LA ((Either a x %1 -> Either b y)
 %1 -> LinearArrow (Either a x) (Either b y))
%1 -> (Either a x %1 -> Either b y)
%1 -> LinearArrow (Either a x) (Either b y)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ (a %1 -> b) -> (x %1 -> y) -> Either a x %1 -> Either b y
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a %1 -> b) -> (c %1 -> d) -> p a c %1 -> p b d
bimap a %1 -> b
f x %1 -> y
g
  unit :: LinearArrow Void Void
unit = (Void %1 -> Void) %1 -> LinearArrow Void Void
forall a b. (a %1 -> b) -> LinearArrow a b
LA ((Void %1 -> Void) %1 -> LinearArrow Void Void)
%1 -> (Void %1 -> Void) %1 -> LinearArrow Void Void
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \case {}

instance Profunctor (->) where
  dimap :: forall s a b t. (s %1 -> a) -> (b %1 -> t) -> (a -> b) -> s -> t
dimap s %1 -> a
f b %1 -> t
g a -> b
h s
x = b %1 -> t
g (a -> b
h (s %1 -> a
f s
x))
instance Strong (,) () (->) where
  first :: forall a b c. (a -> b) -> (a, c) -> (b, c)
first a -> b
f (a
x, c
y) = (a -> b
f a
x, c
y)
instance Strong Either Void (->) where
  first :: forall a b c. (a -> b) -> Either a c -> Either b c
first a -> b
f (Left a
x) = b -> Either b c
forall a b. a -> Either a b
Left (a -> b
f a
x)
  first a -> b
_ (Right c
y) = c -> Either b c
forall a b. b -> Either a b
Right c
y
instance Monoidal (,) () (->) where
  (a -> b
f *** :: forall a b x y. (a -> b) -> (x -> y) -> (a, x) -> (b, y)
*** x -> y
g) (a
a,x
x) = (a -> b
f a
a, x -> y
g x
x)
  unit :: () -> ()
unit () = ()
instance Monoidal Either Void (->) where
  a -> b
f *** :: forall a b x y. (a -> b) -> (x -> y) -> Either a x -> Either b y
*** x -> y
g = (a -> b) -> (x -> y) -> Either a x -> Either b y
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Prelude.bimap a -> b
f x -> y
g
  unit :: Void -> Void
unit = \case {}

-- | An exchange is a pair of translation functions that encode an
-- isomorphism; an @Exchange a b s t@ is equivalent to a @Iso a b s t@.
data Exchange a b s t = Exchange (s %1-> a) (b %1-> t)
instance Profunctor (Exchange a b) where
  dimap :: forall s a b t.
(s %1 -> a) -> (b %1 -> t) -> Exchange a b a b -> Exchange a b s t
dimap s %1 -> a
f b %1 -> t
g (Exchange a %1 -> a
p b %1 -> b
q) = (s %1 -> a) -> (b %1 -> t) -> Exchange a b s t
forall a b s t. (s %1 -> a) -> (b %1 -> t) -> Exchange a b s t
Exchange (a %1 -> a
p (a %1 -> a) %1 -> (s %1 -> a) %1 -> s %1 -> a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. s %1 -> a
f) (b %1 -> t
g (b %1 -> t) %1 -> (b %1 -> b) %1 -> b %1 -> t
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. b %1 -> b
q)

instance Prelude.Functor f => Profunctor (Kleisli f) where
  dimap :: forall s a b t.
(s %1 -> a) -> (b %1 -> t) -> Kleisli f a b -> Kleisli f s t
dimap s %1 -> a
f b %1 -> t
g (Kleisli a -> f b
h) = (s -> f t) -> Kleisli f s t
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\s
x -> (b %1 -> t) %1 -> b -> t
forall a b. (a %1 -> b) %1 -> a -> b
forget b %1 -> t
g (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> a -> f b
h (s %1 -> a
f s
x))

instance Prelude.Functor f => Strong (,) () (Kleisli f) where
  first :: forall a b c. Kleisli f a b -> Kleisli f (a, c) (b, c)
first  (Kleisli a -> f b
f) = ((a, c) -> f (b, c)) -> Kleisli f (a, c) (b, c)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\(a
a,c
b) -> (,c
b) (b -> (b, c)) -> f b -> f (b, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> a -> f b
f a
a)
  second :: forall b c a. Kleisli f b c -> Kleisli f (a, b) (a, c)
second (Kleisli b -> f c
g) = ((a, b) -> f (a, c)) -> Kleisli f (a, b) (a, c)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\(a
a,b
b) -> (a
a,) (c -> (a, c)) -> f c -> f (a, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> b -> f c
g b
b)

instance Prelude.Applicative f => Strong Either Void (Kleisli f) where
  first :: forall a b c. Kleisli f a b -> Kleisli f (Either a c) (Either b c)
first  (Kleisli a -> f b
f) = (Either a c -> f (Either b c))
%1 -> Kleisli f (Either a c) (Either b c)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Either a c -> f (Either b c))
 %1 -> Kleisli f (Either a c) (Either b c))
%1 -> (Either a c -> f (Either b c))
%1 -> Kleisli f (Either a c) (Either b c)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \case
                                   Left  a
x -> (b -> Either b c) -> f b -> f (Either b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.fmap b -> Either b c
forall a b. a -> Either a b
Left (a -> f b
f a
x)
                                   Right c
y -> Either b c -> f (Either b c)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (c -> Either b c
forall a b. b -> Either a b
Right c
y)

instance Prelude.Applicative f => Monoidal (,) () (Kleisli f) where
  Kleisli a -> f b
f *** :: forall a b x y.
Kleisli f a b -> Kleisli f x y -> Kleisli f (a, x) (b, y)
*** Kleisli x -> f y
g = ((a, x) -> f (b, y)) -> Kleisli f (a, x) (b, y)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\(a
x,x
y) -> (,) (b -> y -> (b, y)) -> f b -> f (y -> (b, y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> a -> f b
f a
x f (y -> (b, y)) -> f y -> f (b, y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Prelude.<*> x -> f y
g x
y)
  unit :: Kleisli f () ()
unit = (() -> f ()) -> Kleisli f () ()
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure

instance Prelude.Functor f => Monoidal Either Void (Kleisli f) where
  Kleisli a -> f b
f *** :: forall a b x y.
Kleisli f a b
-> Kleisli f x y -> Kleisli f (Either a x) (Either b y)
*** Kleisli x -> f y
g = (Either a x -> f (Either b y))
%1 -> Kleisli f (Either a x) (Either b y)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Either a x -> f (Either b y))
 %1 -> Kleisli f (Either a x) (Either b y))
%1 -> (Either a x -> f (Either b y))
%1 -> Kleisli f (Either a x) (Either b y)
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \case
    Left a
a -> b -> Either b y
forall a b. a -> Either a b
Left (b -> Either b y) -> f b -> f (Either b y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> a -> f b
f a
a
    Right x
b -> y -> Either b y
forall a b. b -> Either a b
Right (y -> Either b y) -> f y -> f (Either b y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> x -> f y
g x
b
  unit :: Kleisli f Void Void
unit = (Void -> f Void) %1 -> Kleisli f Void Void
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Void -> f Void) %1 -> Kleisli f Void Void)
%1 -> (Void -> f Void) %1 -> Kleisli f Void Void
forall a b. (a %1 -> b) %1 -> a %1 -> b
$ \case {}

-- | A market is a pair of constructor and deconstructor functions that encode
-- a prism; a @Market a b s t@ is equivalent to a @Prism a b s t@.
data Market a b s t = Market (b %1-> t) (s %1-> Either t a)
runMarket :: Market a b s t %1-> (b %1-> t, s %1-> Either t a)
runMarket :: forall a b s t.
Market a b s t %1 -> (b %1 -> t, s %1 -> Either t a)
runMarket (Market b %1 -> t
f s %1 -> Either t a
g) = (b %1 -> t
f, s %1 -> Either t a
g)

instance Profunctor (Market a b) where
  dimap :: forall s a b t.
(s %1 -> a) -> (b %1 -> t) -> Market a b a b -> Market a b s t
dimap s %1 -> a
f b %1 -> t
g (Market b %1 -> b
h a %1 -> Either b a
k) = (b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
forall a b s t.
(b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
Market (b %1 -> t
g (b %1 -> t) %1 -> (b %1 -> b) %1 -> b %1 -> t
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. b %1 -> b
h) ((b %1 -> Either t a)
-> (a %1 -> Either t a) -> Either b a %1 -> Either t a
forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (t %1 -> Either t a
forall a b. a -> Either a b
Left (t %1 -> Either t a) %1 -> (b %1 -> t) %1 -> b %1 -> Either t a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. b %1 -> t
g) a %1 -> Either t a
forall a b. b -> Either a b
Right (Either b a %1 -> Either t a)
%1 -> (a %1 -> Either b a) %1 -> a %1 -> Either t a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. a %1 -> Either b a
k (a %1 -> Either t a) %1 -> (s %1 -> a) %1 -> s %1 -> Either t a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. s %1 -> a
f)

instance Strong Either Void (Market a b) where
  first :: forall a b c.
Market a b a b -> Market a b (Either a c) (Either b c)
first (Market b %1 -> b
f a %1 -> Either b a
g) = (b %1 -> Either b c)
-> (Either a c %1 -> Either (Either b c) a)
-> Market a b (Either a c) (Either b c)
forall a b s t.
(b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
Market (b %1 -> Either b c
forall a b. a -> Either a b
Left (b %1 -> Either b c) %1 -> (b %1 -> b) %1 -> b %1 -> Either b c
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. b %1 -> b
f) ((a %1 -> Either (Either b c) a)
-> (c %1 -> Either (Either b c) a)
-> Either a c
%1 -> Either (Either b c) a
forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either ((b %1 -> Either (Either b c) a)
-> (a %1 -> Either (Either b c) a)
-> Either b a
%1 -> Either (Either b c) a
forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (Either b c %1 -> Either (Either b c) a
forall a b. a -> Either a b
Left (Either b c %1 -> Either (Either b c) a)
%1 -> (b %1 -> Either b c) %1 -> b %1 -> Either (Either b c) a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. b %1 -> Either b c
forall a b. a -> Either a b
Left) a %1 -> Either (Either b c) a
forall a b. b -> Either a b
Right (Either b a %1 -> Either (Either b c) a)
%1 -> (a %1 -> Either b a) %1 -> a %1 -> Either (Either b c) a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. a %1 -> Either b a
g) (Either b c %1 -> Either (Either b c) a
forall a b. a -> Either a b
Left (Either b c %1 -> Either (Either b c) a)
%1 -> (c %1 -> Either b c) %1 -> c %1 -> Either (Either b c) a
forall b c a. (b %1 -> c) %1 -> (a %1 -> b) %1 -> a %1 -> c
. c %1 -> Either b c
forall a b. b -> Either a b
Right))