{-# 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 (..), sell)
import Control.Lens.Internal.Profunctor (WrappedPafb (..))
import Control.Lens (ASetter, ATraversal, cloneTraversal, 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

--------------------------------------------------------------------------------
-- Conversion from Van Laarhoven optics
--------------------------------------------------------------------------------

-- | Converts a 'Control.Lens.Type.Lens' to a 'Profunctor'-based one.
--
-- @
-- 'fromLens' :: 'Control.Lens.Type.Lens' s t a b -> LensP s t a b
-- @
fromLens :: Strong p => LensLike (Context a b) s t a b -> OpticP p s t a b
fromLens :: LensLike (Context a b) s t a b -> OpticP p s t a b
fromLens LensLike (Context a b) s t a b
l p a b
p =
  (s -> (b -> t, a))
-> ((b -> t, b) -> t) -> p (b -> t, a) (b -> t, b) -> p s t
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap
    (\s
s -> let Context b -> t
f a
a = LensLike (Context a b) s t a b
l a -> Context a b b
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell s
s in (b -> t
f, a
a))
    (((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 (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second' p a b
p)

-- | Converts a 'Control.Lens.Type.Iso' to a 'Profunctor'-based one.
--
-- @
-- 'fromIso' :: 'Control.Lens.Type.Iso' s t a b -> IsoP s t a b
-- @
fromIso :: Profunctor p => Optic p Identity s t a b -> OpticP p s t a b
fromIso :: Optic p Identity s t a b -> OpticP p s t a b
fromIso Optic p Identity s t a b
p p a b
pab = (Identity t -> t) -> p s (Identity t) -> p s t
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap Identity t -> t
forall a. Identity a -> a
runIdentity (Optic p Identity s t a b
p ((b -> Identity b) -> p a b -> p a (Identity b)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap b -> Identity b
forall a. a -> Identity a
Identity p a b
pab))

-- | Converts a 'Control.Lens.Type.Prism' to a 'Profunctor'-based one.
--
-- @
-- 'fromPrism' :: 'Control.Lens.Type.Prism' s t a b -> PrismP s t a b
-- @
fromPrism :: Choice p => Optic p Identity s t a b -> OpticP p s t a b
fromPrism :: Optic p Identity s t a b -> OpticP p s t a b
fromPrism Optic p Identity s t a b
p p a b
pab = (Identity t -> t) -> p s (Identity t) -> p s t
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap Identity t -> t
forall a. Identity a -> a
runIdentity (Optic p Identity s t a b
p ((b -> Identity b) -> p a b -> p a (Identity b)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap b -> Identity b
forall a. a -> Identity a
Identity p a b
pab))

-- | Converts a 'Control.Lens.Type.Setter' to a 'Profunctor'-based one.
--
-- @
-- 'fromSetter' :: 'Control.Lens.Type.Setter' s t a b -> SetterP s t a b
-- @
fromSetter :: Mapping p => ASetter s t a b -> OpticP p s t a b
fromSetter :: ASetter s t a b -> OpticP p s t a b
fromSetter ASetter s t a b
s = ((a -> b) -> s -> t) -> OpticP p s t a b
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' :: 'Control.Lens.Type.Traversal' s t a b -> TraversalP s t a b
-- @
fromTraversal :: Traversing p => ATraversal s t a b -> OpticP p s t a b
fromTraversal :: 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)
-> OpticP p s t a b
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' :: PrismP s t a b -> 'Control.Lens.Type.Prism' s t a b
-- @
toPrism :: (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 -> 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) -> Optic p f s t a b
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' :: IsoP s t a b -> 'Control.Lens.Type.Iso' s t a b
-- @
toIso :: (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 -> 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) -> Optic p f s t a b
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' :: LensP s t a b -> 'Control.Lens.Type.Lens' s t a b
-- @
toLens :: Functor f => OpticP (Star f) s t a b -> LensLike f s t a b
toLens :: 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) -> LensLike f s t a b
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' :: SetterP s t a b -> 'Control.Lens.Type.Setter' s t a b
-- @
toSetter :: Settable f => OpticP (Star f) s t a b -> LensLike f s t a b
toSetter :: 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) -> LensLike f s t a b
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' :: TraversalP s t a b -> 'Control.Lens.Type.Traversal' s t a b
-- @
toTraversal :: Applicative f => OpticP (Star f) s t a b -> LensLike f s t a b
toTraversal :: 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) -> LensLike f s t a b
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