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

-- | 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 (..),
    Exchange (..),
    Market (..),
    runMarket,
  )
where

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

-- | 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 = forall (arr :: * -> * -> *) s a t.
Profunctor arr =>
(s %1 -> a) -> arr a t -> arr s t
lmap s %1 -> a
f (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 = 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 forall a (q :: Multiplicity). a %q -> a
id
  {-# INLINE lmap #-}

  rmap :: (b %1 -> t) -> s `arr` b -> s `arr` t
  rmap = forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap forall a (q :: Multiplicity). a %q -> 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)
  infixr 3 *** -- same fixity as base.***
  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 = forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap (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 = forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
swap (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 --
---------------

instance Profunctor (FUN 'One) where
  dimap :: forall s a b t.
(s %1 -> a) -> (b %1 -> t) -> (a %1 -> b) -> s %1 -> t
dimap s %1 -> a
f b %1 -> t
g a %1 -> b
h = b %1 -> t
g forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. a %1 -> b
h forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. s %1 -> a
f

instance Strong (,) () (FUN 'One) where
  first :: forall a b c. (a %1 -> b) -> (a, c) %1 -> (b, c)
first a %1 -> b
f (a
a, c
b) = (a %1 -> b
f a
a, c
b)
  second :: forall b c a. (b %1 -> c) -> (a, b) %1 -> (a, c)
second b %1 -> c
g (a
a, b
b) = (a
a, b %1 -> c
g b
b)

instance Strong Either Void (FUN 'One) where
  first :: forall a b c. (a %1 -> b) -> Either a c %1 -> Either b c
first a %1 -> b
f = forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (forall a b. a -> Either a b
Left forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. a %1 -> b
f) forall a b. b -> Either a b
Right
  second :: forall b c a. (b %1 -> c) -> Either a b %1 -> Either a c
second b %1 -> c
g = forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. b %1 -> c
g)

instance Wandering (FUN 'One) where
  wander :: forall s t a b.
(forall (f :: * -> *).
 Applicative f =>
 (a %1 -> f b) -> s %1 -> f t)
-> (a %1 -> b) -> s %1 -> t
wander forall (f :: * -> *). Applicative f => (a %1 -> f b) -> s %1 -> f t
f a %1 -> b
a_to_b s
s = forall a (p :: Multiplicity). Identity a %p -> a
runIdentity' forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ forall (f :: * -> *). Applicative f => (a %1 -> f b) -> s %1 -> f t
f (forall a. a -> Identity a
Identity forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. a %1 -> b
a_to_b) s
s

instance Monoidal (,) () (FUN 'One) where
  (a %1 -> b
f *** :: forall a b x y. (a %1 -> b) -> (x %1 -> y) -> (a, x) %1 -> (b, y)
*** x %1 -> y
g) (a
a, x
x) = (a %1 -> b
f a
a, x %1 -> y
g x
x)
  unit :: () %1 -> ()
unit = forall a (q :: Multiplicity). a %q -> a
id

instance Monoidal Either Void (FUN 'One) where
  a %1 -> b
f *** :: forall a b x y.
(a %1 -> b) -> (x %1 -> y) -> Either a x %1 -> Either b y
*** x %1 -> y
g = 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 :: Void %1 -> Void
unit = \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) = forall a b. a -> Either a b
Left (a -> b
f a
x)
  first a -> b
_ (Right c
y) = 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 = 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) = forall a b s t. (s %1 -> a) -> (b %1 -> t) -> Exchange a b s t
Exchange (a %1 -> a
p forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. s %1 -> a
f) (b %1 -> t
g forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> 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) = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\s
x -> forall a b. (a %1 -> b) %1 -> a -> b
forget b %1 -> t
g 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) = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\(a
a, c
b) -> (,c
b) 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) = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\(a
a, b
b) -> (a
a,) 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) = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ \case
    Left a
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.fmap forall a b. a -> Either a b
Left (a -> f b
f a
x)
    Right c
y -> forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (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 = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\(a
x, x
y) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> a -> f b
f a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Prelude.<*> x -> f y
g x
y)
  unit :: Kleisli f () ()
unit = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli 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 = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ \case
    Left a
a -> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.<$> a -> f b
f a
a
    Right x
b -> forall a b. b -> Either a b
Right 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 = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> 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) = forall a b s t.
(b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
Market (b %1 -> t
g forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. b %1 -> b
h) (forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (forall a b. a -> Either a b
Left forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. b %1 -> t
g) forall a b. b -> Either a b
Right forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. a %1 -> Either b a
k forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> 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) = forall a b s t.
(b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
Market (forall a b. a -> Either a b
Left forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. b %1 -> b
f) (forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either (forall a b. a -> Either a b
Left forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. forall a b. a -> Either a b
Left) forall a b. b -> Either a b
Right forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. a %1 -> Either b a
g) (forall a b. a -> Either a b
Left forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. forall a b. b -> Either a b
Right))