{- |
Module      : Control.Lens.Monocle
Description : monocles
Copyright   : (C) 2025 - Eitan Chatav
License     : BSD-style (see the file LICENSE)
Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
Stability   : provisional
Portability : non-portable

See Oliveira, Jaskelioff & de Melo,
[On Structuring Functional Programs with Monoidal Profunctors](https://arxiv.org/abs/2207.00852)
-}

module Control.Lens.Monocle
  ( -- * Monocle
    Monocle
  , AMonocle
    -- * Combinators
  , monocle
  , withMonocle
  , cloneMonocle
  , mapMonocle
  , ditraversed
  , forevered
    -- * Monocular
  , Monocular (..), runMonocular
  ) where

import Control.Lens hiding (Traversing)
import Control.Lens.Internal.Profunctor
import Data.Distributive
import Data.Profunctor.Distributor

{- | `Monocle`s are an optic that generalizes
`Control.Lens.Traversal.Traversal`s & `Control.Lens.Grate.Grate`s.

Every `Control.Lens.Iso.Iso` is a `Monocle`.

`Monocle`s are isomorphic to `Monocular`s.
-}
type Monocle s t a b = forall p f.
  (Monoidal p, Applicative f)
    => p a (f b) -> p s (f t)

{- | If you see `AMonocle` in a signature for a function,
the function is expecting a `Monocle`. -}
type AMonocle s t a b =
  Monocular a b a (Identity b) -> Monocular a b s (Identity t)

{- | Build a `Monocle` from a concrete `Monocular`. -}
monocle :: Monocular a b s t -> Monocle s t a b
monocle :: forall a b s t. Monocular a b s t -> Monocle s t a b
monocle Monocular a b s t
mon = 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
. Monocular a b s t -> WrappedPafb f p a b -> WrappedPafb f p s t
forall (p :: * -> * -> *) a b s t.
Monoidal p =>
Monocular a b s t -> p a b -> p s t
runMonocular Monocular a b s t
mon (WrappedPafb f p a b -> WrappedPafb f p s t)
-> (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

{- | Action of `AMonocle` on `Monoidal` `Profunctor`s. -}
mapMonocle :: Monoidal p => AMonocle s t a b -> p a b -> p s t
mapMonocle :: forall (p :: * -> * -> *) s t a b.
Monoidal p =>
AMonocle s t a b -> p a b -> p s t
mapMonocle AMonocle s t a b
mon p a b
p = AMonocle s t a b -> ((s -> a) -> p s b) -> p s t
forall (f :: * -> *) s t a b.
Applicative f =>
AMonocle s t a b -> ((s -> a) -> f b) -> f t
withMonocle AMonocle s t a b
mon (((s -> a) -> p s b) -> p s t) -> ((s -> a) -> p s b) -> p s t
forall a b. (a -> b) -> a -> b
$ \s -> a
f -> (s -> a) -> p a b -> p s b
forall a b c. (a -> b) -> p b c -> p a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap s -> a
f p a b
p

{- | Clone `AMonocle` so that you can reuse the same
monomorphically typed `Monocle` for different purposes.
-}
cloneMonocle :: AMonocle s t a b -> Monocle s t a b
cloneMonocle :: forall s t a b. AMonocle s t a b -> Monocle s t a b
cloneMonocle AMonocle s t a b
mon = 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
. AMonocle s t a b -> WrappedPafb f p a b -> WrappedPafb f p s t
forall (p :: * -> * -> *) s t a b.
Monoidal p =>
AMonocle s t a b -> p a b -> p s t
mapMonocle AMonocle s t a b
mon (WrappedPafb f p a b -> WrappedPafb f p s t)
-> (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

{- | Build a `Monocle` from a `Traversable` & `Distributive`,
homogeneous, countable product.

prop> traverse = ditraversed
prop> cotraversed = ditraversed
-}
ditraversed :: (Traversable g, Distributive g) => Monocle (g a) (g b) a b
ditraversed :: forall (g :: * -> *) a b.
(Traversable g, Distributive g) =>
Monocle (g a) (g b) a b
ditraversed = WrappedPafb f p (g a) (g b) -> p (g a) (f (g b))
forall (f :: * -> *) (p :: * -> * -> *) a b.
WrappedPafb f p a b -> p a (f b)
unwrapPafb (WrappedPafb f p (g a) (g b) -> p (g a) (f (g b)))
-> (p a (f b) -> WrappedPafb f p (g a) (g b))
-> p a (f b)
-> p (g a) (f (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedPafb f p a b -> WrappedPafb f p (g a) (g b)
forall (t :: * -> *) (p :: * -> * -> *) a b.
(Traversable t, Distributive t, Monoidal p) =>
p a b -> p (t a) (t b)
replicateP (WrappedPafb f p a b -> WrappedPafb f p (g a) (g b))
-> (p a (f b) -> WrappedPafb f p a b)
-> p a (f b)
-> WrappedPafb f p (g a) (g b)
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

{- | Repeat action indefinitely. -}
forevered :: Monocle s t () b
forevered :: forall s t b (p :: * -> * -> *) (f :: * -> *).
(Monoidal p, Applicative f) =>
p () (f b) -> p s (f t)
forevered = 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 () (f b) -> WrappedPafb f p s t) -> p () (f b) -> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedPafb f p () b -> WrappedPafb f p s t
forall (p :: * -> * -> *) c a b. Monoidal p => p () c -> p a b
foreverP (WrappedPafb f p () b -> WrappedPafb f p s t)
-> (p () (f b) -> WrappedPafb f p () b)
-> p () (f b)
-> WrappedPafb f p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p () (f b) -> WrappedPafb f p () b
forall (f :: * -> *) (p :: * -> * -> *) a b.
p a (f b) -> WrappedPafb f p a b
WrapPafb

{- | Run `AMonocle` over an `Applicative`. -}
withMonocle :: Applicative f => AMonocle s t a b -> ((s -> a) -> f b) -> f t
withMonocle :: forall (f :: * -> *) s t a b.
Applicative f =>
AMonocle s t a b -> ((s -> a) -> f b) -> f t
withMonocle AMonocle s t a b
mon = Monocular a b s t
-> forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t
forall a b s t.
Monocular a b s t
-> forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t
unMonocular (Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t)
-> Monocular a b s (Identity t) -> Monocular a b s t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AMonocle s t a b
mon (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b)
-> Monocular a b a b -> Monocular a b a (Identity b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Monocular a b a b
forall a b (p :: * -> * -> *). Tokenized a b p => p a b
anyToken))

{- | `Monocular` provides an efficient
concrete representation of `Monocle`s. -}
newtype Monocular a b s t = Monocular
  {forall a b s t.
Monocular a b s t
-> forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t
unMonocular :: forall f. Applicative f => ((s -> a) -> f b) -> f t}
instance Tokenized a b (Monocular a b) where
  anyToken :: Monocular a b a b
anyToken = (forall (f :: * -> *). Applicative f => ((a -> a) -> f b) -> f b)
-> Monocular a b a b
forall a b s t.
(forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t)
-> Monocular a b s t
Monocular (((a -> a) -> f b) -> (a -> a) -> f b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. a -> a
id)
instance Profunctor (Monocular a b) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Monocular a b b c -> Monocular a b a d
dimap a -> b
f c -> d
g (Monocular forall (f :: * -> *). Applicative f => ((b -> a) -> f b) -> f c
k) =
    (forall (f :: * -> *). Applicative f => ((a -> a) -> f b) -> f d)
-> Monocular a b a d
forall a b s t.
(forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t)
-> Monocular a b s t
Monocular ((c -> d) -> f c -> f d
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g (f c -> f d)
-> (((a -> a) -> f b) -> f c) -> ((a -> a) -> f b) -> f d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b -> a) -> f b) -> f c
forall (f :: * -> *). Applicative f => ((b -> a) -> f b) -> f c
k (((b -> a) -> f b) -> f c)
-> (((a -> a) -> f b) -> (b -> a) -> f b)
-> ((a -> a) -> f b)
-> f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a -> a) -> f b) -> ((b -> a) -> a -> a) -> (b -> a) -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b -> a) -> (a -> b) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)))
instance Functor (Monocular a b s) where fmap :: forall a b. (a -> b) -> Monocular a b s a -> Monocular a b s b
fmap = (a -> b) -> Monocular a b s a -> Monocular a b s b
forall b c a. (b -> c) -> Monocular a b a b -> Monocular a b a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
instance Applicative (Monocular a b s) where
  pure :: forall a. a -> Monocular a b s a
pure a
t = (forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f a)
-> Monocular a b s a
forall a b s t.
(forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t)
-> Monocular a b s t
Monocular (f a -> ((s -> a) -> f b) -> f a
forall a. a -> ((s -> a) -> f b) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
t))
  Monocular forall (f :: * -> *).
Applicative f =>
((s -> a) -> f b) -> f (a -> b)
x <*> :: forall a b.
Monocular a b s (a -> b) -> Monocular a b s a -> Monocular a b s b
<*> Monocular forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f a
y = (forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f b)
-> Monocular a b s b
forall a b s t.
(forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t)
-> Monocular a b s t
Monocular ((f (a -> b) -> f a -> f b)
-> (((s -> a) -> f b) -> f (a -> b))
-> (((s -> a) -> f b) -> f a)
-> ((s -> a) -> f b)
-> f b
forall a b c.
(a -> b -> c)
-> (((s -> a) -> f b) -> a)
-> (((s -> a) -> f b) -> b)
-> ((s -> a) -> f b)
-> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) ((s -> a) -> f b) -> f (a -> b)
forall (f :: * -> *).
Applicative f =>
((s -> a) -> f b) -> f (a -> b)
x ((s -> a) -> f b) -> f a
forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f a
y)

{- | Run a `Monocular` on a `Monoidal` `Profunctor`. -}
runMonocular :: Monoidal p => Monocular a b s t -> p a b -> p s t
runMonocular :: forall (p :: * -> * -> *) a b s t.
Monoidal p =>
Monocular a b s t -> p a b -> p s t
runMonocular (Monocular forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t
k) p a b
p = ((s -> a) -> p s b) -> p s t
forall (f :: * -> *). Applicative f => ((s -> a) -> f b) -> f t
k (((s -> a) -> p s b) -> p s t) -> ((s -> a) -> p s b) -> p s t
forall a b. (a -> b) -> a -> b
$ \s -> a
f -> (s -> a) -> p a b -> p s b
forall a b c. (a -> b) -> p b c -> p a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap s -> a
f p a b
p