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

module Control.Lens.Diopter
  ( -- * Diopter
    Diopter
  , ADiopter
    -- * Combinators
  , diopter
  , withDiopter
  , cloneDiopter
  , mapDiopter
  , optioned
  , manied
  , homogenized
    -- * Dioptrice
  , Dioptrice (..), runDioptrice
  ) where

import Control.Lens
import Control.Lens.Internal.Profunctor
import Data.Profunctor.Distributor
import Data.Void
import GHC.Generics

{- | `Diopter`s are an optic that generalizes
`Control.Lens.Bifocal.Bifocal`s and `Control.Lens.Traversal.Traversal`s.

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

`Diopter`s are isomorphic to `Dioptrice`s.
-}
type Diopter s t a b = forall p f.
  (Distributor p, Applicative f)
    => p a (f b) -> p s (f t)

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

{- | Build a `Diopter`. -}
diopter :: Homogeneous h => (s -> h a) -> (h b -> t) -> Diopter s t a b
diopter :: forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Diopter s t a b
diopter s -> h a
f h b -> t
g = 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
. Dioptrice a b s t -> WrappedPafb f p a b -> WrappedPafb f p s t
forall (p :: * -> * -> *) a b s t.
Distributor p =>
Dioptrice a b s t -> p a b -> p s t
runDioptrice ((s -> h a) -> (h b -> t) -> Dioptrice a b s t
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice s -> h a
f h b -> t
g) (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

{- | Convert `ADiopter` to the pair of functions that characterize it. -}
withDiopter
  :: ADiopter s t a b
  -> (forall h. Homogeneous h => (s -> h a) -> (h b -> t) -> r)
  -> r
withDiopter :: forall s t a b r.
ADiopter s t a b
-> (forall (h :: * -> *).
    Homogeneous h =>
    (s -> h a) -> (h b -> t) -> r)
-> r
withDiopter ADiopter s t a b
dio forall (h :: * -> *).
Homogeneous h =>
(s -> h a) -> (h b -> t) -> r
k = case (Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t)
-> Dioptrice a b s (Identity t) -> Dioptrice a b s t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ADiopter s t a b
dio (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b)
-> Dioptrice a b a b -> Dioptrice a b a (Identity b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dioptrice a b a b
forall a b (p :: * -> * -> *). Tokenized a b p => p a b
anyToken)) of
  Dioptrice s -> h a
f h b -> t
g -> (s -> h a) -> (h b -> t) -> r
forall (h :: * -> *).
Homogeneous h =>
(s -> h a) -> (h b -> t) -> r
k s -> h a
f h b -> t
g

{- | Action of `ADiopter` on `Distributor`s. -}
mapDiopter :: Distributor p => ADiopter s t a b -> p a b -> p s t
mapDiopter :: forall (p :: * -> * -> *) s t a b.
Distributor p =>
ADiopter s t a b -> p a b -> p s t
mapDiopter ADiopter s t a b
dio = ADiopter s t a b
-> (forall {h :: * -> *}.
    Homogeneous h =>
    (s -> h a) -> (h b -> t) -> p a b -> p s t)
-> p a b
-> p s t
forall s t a b r.
ADiopter s t a b
-> (forall (h :: * -> *).
    Homogeneous h =>
    (s -> h a) -> (h b -> t) -> r)
-> r
withDiopter ADiopter s t a b
dio ((forall {h :: * -> *}.
  Homogeneous h =>
  (s -> h a) -> (h b -> t) -> p a b -> p s t)
 -> p a b -> p s t)
-> (forall {h :: * -> *}.
    Homogeneous h =>
    (s -> h a) -> (h b -> t) -> p a b -> p s t)
-> p a b
-> p s t
forall a b. (a -> b) -> a -> b
$ \s -> h a
f h b -> t
g -> (s -> h a) -> (h b -> t) -> p (h a) (h 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 -> h a
f h b -> t
g (p (h a) (h b) -> p s t)
-> (p a b -> p (h a) (h b)) -> p a b -> p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (h a) (h b)
forall (t :: * -> *) (p :: * -> * -> *) a b.
(Homogeneous t, Distributor p) =>
p a b -> p (t a) (t b)
forall (p :: * -> * -> *) a b.
Distributor p =>
p a b -> p (h a) (h b)
homogeneously

{- | Clone `ADiopter` so that you can reuse the same
monomorphically typed `Diopter` for different purposes.
-}
cloneDiopter :: ADiopter s t a b -> Diopter s t a b
cloneDiopter :: forall s t a b. ADiopter s t a b -> Diopter s t a b
cloneDiopter ADiopter s t a b
dio = ADiopter s t a b
-> (forall (h :: * -> *).
    Homogeneous h =>
    (s -> h a) -> (h b -> t) -> p a (f b) -> p s (f t))
-> p a (f b)
-> p s (f t)
forall s t a b r.
ADiopter s t a b
-> (forall (h :: * -> *).
    Homogeneous h =>
    (s -> h a) -> (h b -> t) -> r)
-> r
withDiopter ADiopter s t a b
dio (s -> h a) -> (h b -> t) -> p a (f b) -> p s (f t)
(s -> h a) -> (h b -> t) -> Diopter s t a b
forall (h :: * -> *).
Homogeneous h =>
(s -> h a) -> (h b -> t) -> p a (f b) -> p s (f t)
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Diopter s t a b
diopter

{- | One or none. -}
optioned :: Diopter (Maybe a) (Maybe b) a b
optioned :: forall a b (p :: * -> * -> *) (f :: * -> *).
(Distributor p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
optioned = WrappedPafb f p (Maybe a) (Maybe b) -> p (Maybe a) (f (Maybe b))
forall (f :: * -> *) (p :: * -> * -> *) a b.
WrappedPafb f p a b -> p a (f b)
unwrapPafb (WrappedPafb f p (Maybe a) (Maybe b) -> p (Maybe a) (f (Maybe b)))
-> (p a (f b) -> WrappedPafb f p (Maybe a) (Maybe b))
-> p a (f b)
-> p (Maybe a) (f (Maybe b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedPafb f p a b -> WrappedPafb f p (Maybe a) (Maybe b)
forall a b.
WrappedPafb f p a b -> WrappedPafb f p (Maybe a) (Maybe b)
forall (p :: * -> * -> *) a b.
Distributor p =>
p a b -> p (Maybe a) (Maybe b)
optionalP (WrappedPafb f p a b -> WrappedPafb f p (Maybe a) (Maybe b))
-> (p a (f b) -> WrappedPafb f p a b)
-> p a (f b)
-> WrappedPafb f p (Maybe a) (Maybe 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

{- | Zero or more. -}
manied :: Diopter [a] [b] a b
manied :: forall a b (p :: * -> * -> *) (f :: * -> *).
(Distributor p, Applicative f) =>
p a (f b) -> p [a] (f [b])
manied = WrappedPafb f p [a] [b] -> p [a] (f [b])
forall (f :: * -> *) (p :: * -> * -> *) a b.
WrappedPafb f p a b -> p a (f b)
unwrapPafb (WrappedPafb f p [a] [b] -> p [a] (f [b]))
-> (p a (f b) -> WrappedPafb f p [a] [b])
-> p a (f b)
-> p [a] (f [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedPafb f p a b -> WrappedPafb f p [a] [b]
forall a b. WrappedPafb f p a b -> WrappedPafb f p [a] [b]
forall (p :: * -> * -> *) a b. Distributor p => p a b -> p [a] [b]
manyP (WrappedPafb f p a b -> WrappedPafb f p [a] [b])
-> (p a (f b) -> WrappedPafb f p a b)
-> p a (f b)
-> WrappedPafb f p [a] [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

{- | Build a `Diopter` from a `Homogeneous`
countable sum of countable products.

prop> traverse = homogenized
prop> homogenized = ditraversed
-}
homogenized :: Homogeneous t => Diopter (t a) (t b) a b
homogenized :: forall (t :: * -> *) a b. Homogeneous t => Diopter (t a) (t b) a b
homogenized = WrappedPafb f p (t a) (t b) -> p (t a) (f (t b))
forall (f :: * -> *) (p :: * -> * -> *) a b.
WrappedPafb f p a b -> p a (f b)
unwrapPafb (WrappedPafb f p (t a) (t b) -> p (t a) (f (t b)))
-> (p a (f b) -> WrappedPafb f p (t a) (t b))
-> p a (f b)
-> p (t a) (f (t b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedPafb f p a b -> WrappedPafb f p (t a) (t b)
forall (t :: * -> *) (p :: * -> * -> *) a b.
(Homogeneous t, Distributor p) =>
p a b -> p (t a) (t b)
forall (p :: * -> * -> *) a b.
Distributor p =>
p a b -> p (t a) (t b)
homogeneously (WrappedPafb f p a b -> WrappedPafb f p (t a) (t b))
-> (p a (f b) -> WrappedPafb f p a b)
-> p a (f b)
-> WrappedPafb f p (t a) (t 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

{- | A `Dioptrice` provides efficient access
to some pair of functions that make up a `Diopter`.
-}
data Dioptrice a b s t where
  Dioptrice
    :: Homogeneous h
    => (s -> h a)
    -> (h b -> t)
    -> Dioptrice a b s t
instance Tokenized a b (Dioptrice a b) where
  anyToken :: Dioptrice a b a b
anyToken = (a -> Par1 a) -> (Par1 b -> b) -> Dioptrice a b a b
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice a -> Par1 a
forall p. p -> Par1 p
Par1 Par1 b -> b
forall p. Par1 p -> p
unPar1
instance Profunctor (Dioptrice a b) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Dioptrice a b b c -> Dioptrice a b a d
dimap a -> b
f c -> d
g (Dioptrice b -> h a
sa h b -> c
bt) = (a -> h a) -> (h b -> d) -> Dioptrice a b a d
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice (b -> h a
sa (b -> h a) -> (a -> b) -> a -> h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (c -> d
g (c -> d) -> (h b -> c) -> h b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h b -> c
bt)
instance Functor (Dioptrice a b s) where fmap :: forall a b. (a -> b) -> Dioptrice a b s a -> Dioptrice a b s b
fmap = (a -> b) -> Dioptrice a b s a -> Dioptrice a b s b
forall b c a. (b -> c) -> Dioptrice a b a b -> Dioptrice a b a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
instance Applicative (Dioptrice a b s) where
  pure :: forall a. a -> Dioptrice a b s a
pure a
t = (s -> U1 a) -> (U1 b -> a) -> Dioptrice a b s a
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice (U1 a -> s -> U1 a
forall a b. a -> b -> a
const U1 a
forall k (p :: k). U1 p
U1) (a -> U1 b -> a
forall a b. a -> b -> a
const a
t)
  Dioptrice s -> h a
fx h b -> a -> b
gx <*> :: forall a b.
Dioptrice a b s (a -> b) -> Dioptrice a b s a -> Dioptrice a b s b
<*> Dioptrice s -> h a
fy h b -> a
gy = (s -> (:*:) h h a) -> ((:*:) h h b -> b) -> Dioptrice a b s b
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice
    (\s
s -> s -> h a
fx s
s h a -> h a -> (:*:) h h a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: s -> h a
fy s
s)
    (\(h b
h :*: h b
g) -> h b -> a -> b
gx h b
h (h b -> a
gy h b
g))
instance Distributor (Dioptrice a b) where
  zeroP :: Dioptrice a b Void Void
zeroP = (Void -> V1 a) -> (V1 b -> Void) -> Dioptrice a b Void Void
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice Void -> V1 a
forall a. Void -> a
absurd V1 b -> Void
forall x. V1 b -> x
ridiculous
    where
      ridiculous :: V1 b -> x
      ridiculous :: forall x. V1 b -> x
ridiculous = (V1 b -> x
\case)
  Dioptrice a -> h a
fx h b -> b
gx >+< :: forall a b c d.
Dioptrice a b a b
-> Dioptrice a b c d -> Dioptrice a b (Either a c) (Either b d)
>+< Dioptrice c -> h a
fy h b -> d
gy = (Either a c -> (:+:) h h a)
-> ((:+:) h h b -> Either b d)
-> Dioptrice a b (Either a c) (Either b d)
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice
    ((a -> (:+:) h h a)
-> (c -> (:+:) h h a) -> Either a c -> (:+:) h h a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (h a -> (:+:) h h a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (h a -> (:+:) h h a) -> (a -> h a) -> a -> (:+:) h h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> h a
fx) (h a -> (:+:) h h a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (h a -> (:+:) h h a) -> (c -> h a) -> c -> (:+:) h h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> h a
fy))
    (\case {L1 h b
h -> b -> Either b d
forall a b. a -> Either a b
Left (h b -> b
gx h b
h); R1 h b
j -> d -> Either b d
forall a b. b -> Either a b
Right (h b -> d
gy h b
j)})
  optionalP :: forall a b. Dioptrice a b a b -> Dioptrice a b (Maybe a) (Maybe b)
optionalP (Dioptrice a -> h a
f h b -> b
g) = (Maybe a -> (:.:) Maybe h a)
-> ((:.:) Maybe h b -> Maybe b)
-> Dioptrice a b (Maybe a) (Maybe b)
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice
    (Maybe (h a) -> (:.:) Maybe h a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (Maybe (h a) -> (:.:) Maybe h a)
-> (Maybe a -> Maybe (h a)) -> Maybe a -> (:.:) Maybe h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> h a) -> Maybe a -> Maybe (h a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> h a
f)
    ((h b -> b) -> Maybe (h b) -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap h b -> b
g (Maybe (h b) -> Maybe b)
-> ((:.:) Maybe h b -> Maybe (h b)) -> (:.:) Maybe h b -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) Maybe h b -> Maybe (h b)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1)
  manyP :: forall a b. Dioptrice a b a b -> Dioptrice a b [a] [b]
manyP (Dioptrice a -> h a
f h b -> b
g) = ([a] -> (:.:) [] h a)
-> ((:.:) [] h b -> [b]) -> Dioptrice a b [a] [b]
forall (h :: * -> *) s a b t.
Homogeneous h =>
(s -> h a) -> (h b -> t) -> Dioptrice a b s t
Dioptrice
    ([h a] -> (:.:) [] h a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 ([h a] -> (:.:) [] h a) -> ([a] -> [h a]) -> [a] -> (:.:) [] h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> h a) -> [a] -> [h a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> h a
f)
    ((h b -> b) -> [h b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap h b -> b
g ([h b] -> [b]) -> ((:.:) [] h b -> [h b]) -> (:.:) [] h b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) [] h b -> [h b]
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1)

{- | Run a `Dioptrice` on a `Distributor`. -}
runDioptrice
  :: Distributor p
  => Dioptrice a b s t
  -> p a b -> p s t
runDioptrice :: forall (p :: * -> * -> *) a b s t.
Distributor p =>
Dioptrice a b s t -> p a b -> p s t
runDioptrice (Dioptrice s -> h a
f h b -> t
g) = (s -> h a) -> (h b -> t) -> p (h a) (h 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 -> h a
f h b -> t
g (p (h a) (h b) -> p s t)
-> (p a b -> p (h a) (h b)) -> p a b -> p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (h a) (h b)
forall (t :: * -> *) (p :: * -> * -> *) a b.
(Homogeneous t, Distributor p) =>
p a b -> p (t a) (t b)
forall (p :: * -> * -> *) a b.
Distributor p =>
p a b -> p (h a) (h b)
homogeneously