{-# LANGUAGE CPP #-}
-------------------------------------------------------------------------------

-- | This module provides conversion functions between the optics defined in

-- this library and 'Profunctor'-based optics.

--

-- The goal of these functions is to provide an interoperability layer between

-- the two styles of optics, and not to reimplement all the library in terms of

-- 'Profunctor' optics.


module Control.Lens.Profunctor
  ( -- * Profunctor optic

    OpticP

    -- * Conversion from Van Laarhoven optics

  , fromLens
  , fromIso
  , fromPrism
  , fromSetter
  , fromTraversal

    -- * Conversion to Van Laarhoven optics

  , toLens
  , toIso
  , toPrism
  , toSetter
  , toTraversal
  ) where

import Prelude ()

import Control.Lens.Internal.Prelude
import Control.Lens.Type (Optic, LensLike)
import Control.Lens.Internal.Context (Context (..), runPretext, sell)
import Control.Lens.Internal.Profunctor (WrappedPafb (..))
import Control.Lens
  ( ALens, AnIso, APrism, ASetter, ATraversal
  , cloneTraversal, withIso, withPrism, Settable
  )
import Data.Profunctor (Star (..))
import Data.Profunctor.Mapping (Mapping (..))
import Data.Profunctor.Traversing (Traversing (..))

-- | Profunctor optic.

type OpticP p s t a b = p a b -> p s t

-- $setup

-- >>> import Control.Lens


--------------------------------------------------------------------------------

-- Conversion from Van Laarhoven optics

--------------------------------------------------------------------------------


-- | Converts a 'Control.Lens.Type.Lens' to a 'Profunctor'-based one.

--

-- >>> fromLens _1 (+1) (3, "hello")

-- (4,"hello")

fromLens :: Strong p => ALens s t a b -> OpticP p s t a b
fromLens :: forall (p :: * -> * -> *) s t a b.
Strong p =>
ALens s t a b -> OpticP p s t a b
fromLens ALens s t a b
k p a b
p = (s -> (b -> t, a))
-> ((b -> t, b) -> t) -> p (b -> t, a) (b -> t, b) -> p s t
forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> (b -> t, a)
project (((b -> t) -> b -> t) -> (b -> t, b) -> t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (b -> t) -> b -> t
forall a. a -> a
id) (p a b -> p (b -> t, a) (b -> t, b)
forall a b c. p a b -> p (c, a) (c, b)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second' p a b
p)
  where
    project :: s -> (b -> t, a)
project s
s = case Pretext (->) a b t
-> forall (f :: * -> *). Functor f => (a -> f b) -> f t
forall (p :: * -> * -> *) a b t.
Pretext p a b t
-> forall (f :: * -> *). Functor f => p a (f b) -> f t
runPretext (ALens s t a b
k a -> Pretext (->) a b b
forall a b. a -> Pretext (->) a b b
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell s
s) ((b -> b) -> a -> Context a b b
forall a b t. (b -> t) -> a -> Context a b t
Context b -> b
forall a. a -> a
id) of
      Context b -> t
bt a
a -> (b -> t
bt, a
a)

-- | Converts an 'Control.Lens.Type.Iso' to a 'Profunctor'-based one.

--

-- >>> fromIso (iso fromEnum toEnum) succ 'a' :: Char

-- 'b'

fromIso :: Profunctor p => AnIso s t a b -> OpticP p s t a b
fromIso :: forall (p :: * -> * -> *) s t a b.
Profunctor p =>
AnIso s t a b -> OpticP p s t a b
fromIso AnIso s t a b
k = AnIso s t a b
-> ((s -> a) -> (b -> t) -> OpticP p s t a b) -> OpticP p s t a b
forall s t a b r. AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso AnIso s t a b
k (s -> a) -> (b -> t) -> OpticP p s t a b
forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap

-- | Converts a 'Control.Lens.Type.Prism' to a 'Profunctor'-based one.

--

-- >>> fromPrism _Just (+1) (Just 3)

-- Just 4

--

-- >>> fromPrism _Just (+1) Nothing

-- Nothing

fromPrism :: Choice p => APrism s t a b -> OpticP p s t a b
fromPrism :: forall (p :: * -> * -> *) s t a b.
Choice p =>
APrism s t a b -> OpticP p s t a b
fromPrism APrism s t a b
k = APrism s t a b
-> ((b -> t) -> (s -> Either t a) -> OpticP p s t a b)
-> OpticP p s t a b
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k (((b -> t) -> (s -> Either t a) -> OpticP p s t a b)
 -> OpticP p s t a b)
-> ((b -> t) -> (s -> Either t a) -> OpticP p s t a b)
-> OpticP p s t a b
forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta ->
  (s -> Either t a)
-> (Either t b -> t) -> p (Either t a) (Either t b) -> p s t
forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta ((t -> t) -> (b -> t) -> Either t b -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> t
forall a. a -> a
id b -> t
bt) (p (Either t a) (Either t b) -> p s t)
-> (p a b -> p (Either t a) (Either t b)) -> OpticP p s t a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Either t a) (Either t b)
forall a b c. p a b -> p (Either c a) (Either c b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

-- | Converts a 'Control.Lens.Type.Setter' to a 'Profunctor'-based one.

fromSetter :: Mapping p => ASetter s t a b -> OpticP p s t a b
fromSetter :: forall (p :: * -> * -> *) s t a b.
Mapping p =>
ASetter s t a b -> OpticP p s t a b
fromSetter ASetter s t a b
s = ((a -> b) -> s -> t) -> p a b -> p s t
forall a b s t. ((a -> b) -> s -> t) -> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Mapping p =>
((a -> b) -> s -> t) -> p a b -> p s t
roam (a -> b) -> s -> t
s'
  where
    s' :: (a -> b) -> s -> t
s' a -> b
f = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter s t a b
s (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- | Converts a 'Control.Lens.Type.Traversal' to a 'Profunctor'-based one.

fromTraversal :: Traversing p => ATraversal s t a b -> OpticP p s t a b
fromTraversal :: forall (p :: * -> * -> *) s t a b.
Traversing p =>
ATraversal s t a b -> OpticP p s t a b
fromTraversal ATraversal s t a b
l = (forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander (ATraversal s t a b
-> forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
forall s t a b. ATraversal s t a b -> Traversal s t a b
cloneTraversal ATraversal s t a b
l)

--------------------------------------------------------------------------------

-- Conversion to Van Laarhoven optics

--------------------------------------------------------------------------------


-- | Obtain a 'Control.Lens.Type.Prism' from a 'Profunctor'-based one.

toPrism :: (Choice p, Applicative f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b
toPrism :: forall (p :: * -> * -> *) (f :: * -> *) s t a b.
(Choice p, Applicative f) =>
OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b
toPrism OpticP (WrappedPafb f p) s t a b
p = WrappedPafb f p s t -> p s (f t)
forall (f :: * -> *) (p :: * -> * -> *) a b.
WrappedPafb f p a b -> p a (f b)
unwrapPafb (WrappedPafb f p s t -> p s (f t))
-> (p a (f b) -> WrappedPafb f p s t) -> p a (f b) -> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpticP (WrappedPafb f p) s t a b
p OpticP (WrappedPafb f p) s t a b
-> (p a (f b) -> WrappedPafb f p a b)
-> p a (f b)
-> WrappedPafb f p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> WrappedPafb f p a b
forall (f :: * -> *) (p :: * -> * -> *) a b.
p a (f b) -> WrappedPafb f p a b
WrapPafb

-- | Obtain a 'Control.Lens.Type.Iso' from a 'Profunctor'-based one.

toIso :: (Profunctor p, Functor f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b
toIso :: forall (p :: * -> * -> *) (f :: * -> *) s t a b.
(Profunctor p, Functor f) =>
OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b
toIso OpticP (WrappedPafb f p) s t a b
p = WrappedPafb f p s t -> p s (f t)
forall (f :: * -> *) (p :: * -> * -> *) a b.
WrappedPafb f p a b -> p a (f b)
unwrapPafb (WrappedPafb f p s t -> p s (f t))
-> (p a (f b) -> WrappedPafb f p s t) -> p a (f b) -> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpticP (WrappedPafb f p) s t a b
p OpticP (WrappedPafb f p) s t a b
-> (p a (f b) -> WrappedPafb f p a b)
-> p a (f b)
-> WrappedPafb f p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> WrappedPafb f p a b
forall (f :: * -> *) (p :: * -> * -> *) a b.
p a (f b) -> WrappedPafb f p a b
WrapPafb

-- | Obtain a 'Control.Lens.Type.Lens' from a 'Profunctor'-based one.

toLens :: Functor f => OpticP (Star f) s t a b -> LensLike f s t a b
toLens :: forall (f :: * -> *) s t a b.
Functor f =>
OpticP (Star f) s t a b -> LensLike f s t a b
toLens OpticP (Star f) s t a b
p = Star f s t -> s -> f t
forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar (Star f s t -> s -> f t)
-> ((a -> f b) -> Star f s t) -> (a -> f b) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpticP (Star f) s t a b
p OpticP (Star f) s t a b
-> ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> Star f a b
forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star

-- | Obtain a 'Control.Lens.Type.Setter' from a 'Profunctor'-based one.

toSetter :: Settable f => OpticP (Star f) s t a b -> LensLike f s t a b
toSetter :: forall (f :: * -> *) s t a b.
Settable f =>
OpticP (Star f) s t a b -> LensLike f s t a b
toSetter OpticP (Star f) s t a b
p = Star f s t -> s -> f t
forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar (Star f s t -> s -> f t)
-> ((a -> f b) -> Star f s t) -> (a -> f b) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpticP (Star f) s t a b
p OpticP (Star f) s t a b
-> ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> Star f a b
forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star

-- | Obtain a 'Control.Lens.Type.Traversal' from a 'Profunctor'-based one.

toTraversal :: Applicative f => OpticP (Star f) s t a b -> LensLike f s t a b
toTraversal :: forall (f :: * -> *) s t a b.
Applicative f =>
OpticP (Star f) s t a b -> LensLike f s t a b
toTraversal OpticP (Star f) s t a b
p = Star f s t -> s -> f t
forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar (Star f s t -> s -> f t)
-> ((a -> f b) -> Star f s t) -> (a -> f b) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpticP (Star f) s t a b
p OpticP (Star f) s t a b
-> ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> Star f a b
forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star