{-# LANGUAGE RankNTypes #-}
module Fresnel.Lens
( -- * Lenses
  Lens
, Lens'
, IsLens
  -- * Construction
, lens
  -- * Elimination
, withLens
  -- * Combinators
, choosing
, chosen
, alongside
, inside
, devoid
, united
  -- * Unpacked
, UnpackedLens(..)
, unpackedLens
) where

import Control.Arrow ((&&&), (***))
import Data.Bifunctor (Bifunctor(..))
import Data.Profunctor
import Data.Profunctor.Rep (Corepresentable(..))
import Data.Profunctor.Sieve (Cosieve(..))
import Data.Void (Void, absurd)
import Fresnel.Getter (getting, view)
import Fresnel.Iso.Internal (IsIso)
import Fresnel.Lens.Internal (IsLens)
import Fresnel.Optic
import Fresnel.Setter (set)

-- Lenses

type Lens s t a b = forall p . IsLens p => Optic p s t a b

type Lens' s a = Lens s s a a


-- Construction

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens :: forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens s -> a
get s -> b -> t
set = (s -> (s, a)) -> ((s, b) -> t) -> p (s, a) (s, 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 -> s
forall a. a -> a
id (s -> s) -> (s -> a) -> s -> (s, a)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& s -> a
get) ((s -> b -> t) -> (s, b) -> t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> b -> t
set) (p (s, a) (s, b) -> p s t)
-> (p a b -> p (s, a) (s, b)) -> p a b -> p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (s, a) (s, 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'


-- Elimination

withLens :: Lens s t a b -> (((s -> a) -> (s -> b -> t) -> r) -> r)
withLens :: forall s t a b r.
Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
withLens Lens s t a b
o = UnpackedLens a b s t
-> forall r. ((s -> a) -> (s -> b -> t) -> r) -> r
forall a b s t.
UnpackedLens a b s t
-> forall r. ((s -> a) -> (s -> b -> t) -> r) -> r
withUnpackedLens (Optic (UnpackedLens a b) s t a b
Lens s t a b
o ((a -> a) -> (a -> b -> b) -> UnpackedLens a b a b
forall s a b t. (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t
unpackedLens a -> a
forall a. a -> a
id ((b -> b) -> a -> b -> b
forall a b. a -> b -> a
const b -> b
forall a. a -> a
id)))


-- Combinators

choosing :: Lens s1 t1 a b -> Lens s2 t2 a b -> Lens (Either s1 s2) (Either t1 t2) a b
choosing :: forall s1 t1 a b s2 t2.
Lens s1 t1 a b
-> Lens s2 t2 a b -> Lens (Either s1 s2) (Either t1 t2) a b
choosing Lens s1 t1 a b
l Lens s2 t2 a b
r = (Either s1 s2 -> a)
-> (Either s1 s2 -> b -> Either t1 t2)
-> Lens (Either s1 s2) (Either t1 t2) a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
  ((s1 -> a) -> (s2 -> a) -> Either s1 s2 -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Getter s1 a -> s1 -> a
forall s a. Getter s a -> s -> a
view (Optic p s1 t1 a b -> Optic' p s1 a
forall (p :: * -> * -> *) s t a b.
(Profunctor p, Bicontravariant p) =>
Optic p s t a b -> Optic' p s a
getting Optic p s1 t1 a b
Lens s1 t1 a b
l)) (Getter s2 a -> s2 -> a
forall s a. Getter s a -> s -> a
view (Optic p s2 t2 a b -> Optic' p s2 a
forall (p :: * -> * -> *) s t a b.
(Profunctor p, Bicontravariant p) =>
Optic p s t a b -> Optic' p s a
getting Optic p s2 t2 a b
Lens s2 t2 a b
r)))
  (\ Either s1 s2
e b
b -> (s1 -> t1) -> (s2 -> t2) -> Either s1 s2 -> Either t1 t2
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Setter s1 t1 a b -> b -> s1 -> t1
forall s t a b. Setter s t a b -> b -> s -> t
set Optic p s1 t1 a b
Lens s1 t1 a b
Setter s1 t1 a b
l b
b) (Setter s2 t2 a b -> b -> s2 -> t2
forall s t a b. Setter s t a b -> b -> s -> t
set Optic p s2 t2 a b
Lens s2 t2 a b
Setter s2 t2 a b
r b
b) Either s1 s2
e)

chosen :: Lens (Either a a) (Either b b) a b
chosen :: forall a b (p :: * -> * -> *).
IsLens p =>
Optic p (Either a a) (Either b b) a b
chosen = Lens a b a b -> Lens a b a b -> Lens (Either a a) (Either b b) a b
forall s1 t1 a b s2 t2.
Lens s1 t1 a b
-> Lens s2 t2 a b -> Lens (Either s1 s2) (Either t1 t2) a b
choosing p a b -> p a b
forall a. a -> a
Lens a b a b
id p a b -> p a b
forall a. a -> a
Lens a b a b
id

alongside :: Lens s1 t1 a1 b1 -> Lens s2 t2 a2 b2 -> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2)
alongside :: forall s1 t1 a1 b1 s2 t2 a2 b2.
Lens s1 t1 a1 b1
-> Lens s2 t2 a2 b2 -> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2)
alongside Lens s1 t1 a1 b1
o1 Lens s2 t2 a2 b2
o2 = Lens s1 t1 a1 b1
-> ((s1 -> a1)
    -> (s1 -> b1 -> t1) -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
-> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2)
forall s t a b r.
Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
withLens Optic p s1 t1 a1 b1
Lens s1 t1 a1 b1
o1 (((s1 -> a1)
  -> (s1 -> b1 -> t1) -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
 -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
-> ((s1 -> a1)
    -> (s1 -> b1 -> t1) -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
-> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2)
forall a b. (a -> b) -> a -> b
$ \ s1 -> a1
get1 s1 -> b1 -> t1
set1 -> Lens s2 t2 a2 b2
-> ((s2 -> a2)
    -> (s2 -> b2 -> t2) -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
-> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2)
forall s t a b r.
Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
withLens Optic p s2 t2 a2 b2
Lens s2 t2 a2 b2
o2 (((s2 -> a2)
  -> (s2 -> b2 -> t2) -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
 -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
-> ((s2 -> a2)
    -> (s2 -> b2 -> t2) -> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2))
-> Optic p (s1, s2) (t1, t2) (a1, a2) (b1, b2)
forall a b. (a -> b) -> a -> b
$ \ s2 -> a2
get2 s2 -> b2 -> t2
set2 ->
  ((s1, s2) -> (a1, a2))
-> ((s1, s2) -> (b1, b2) -> (t1, t2))
-> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (s1 -> a1
get1 (s1 -> a1) -> (s2 -> a2) -> (s1, s2) -> (a1, a2)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** s2 -> a2
get2) (((b1 -> t1) -> (b2 -> t2) -> (b1, b2) -> (t1, t2))
-> (b1 -> t1, b2 -> t2) -> (b1, b2) -> (t1, t2)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (b1 -> t1) -> (b2 -> t2) -> (b1, b2) -> (t1, t2)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) ((b1 -> t1, b2 -> t2) -> (b1, b2) -> (t1, t2))
-> ((s1, s2) -> (b1 -> t1, b2 -> t2))
-> (s1, s2)
-> (b1, b2)
-> (t1, t2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s1 -> b1 -> t1
set1 (s1 -> b1 -> t1)
-> (s2 -> b2 -> t2) -> (s1, s2) -> (b1 -> t1, b2 -> t2)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** s2 -> b2 -> t2
set2))

inside :: Corepresentable p => Lens s t a b -> Lens (p e s) (p e t) (p e a) (p e b)
inside :: forall (p :: * -> * -> *) s t a b e.
Corepresentable p =>
Lens s t a b -> Lens (p e s) (p e t) (p e a) (p e b)
inside Lens s t a b
o = (p e s -> p e a)
-> (p e s -> p e b -> p e t)
-> Lens (p e s) (p e t) (p e a) (p e b)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
  (\ p e s
s -> (Corep p e -> a) -> p e a
forall d c. (Corep p d -> c) -> p d c
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate (Getter s a -> s -> a
forall s a. Getter s a -> s -> a
view (Optic p s t a b -> Optic' p s a
forall (p :: * -> * -> *) s t a b.
(Profunctor p, Bicontravariant p) =>
Optic p s t a b -> Optic' p s a
getting Optic p s t a b
Lens s t a b
o) (s -> a) -> (Corep p e -> s) -> Corep p e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p e s -> Corep p e -> s
forall a b. p a b -> Corep p a -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve p e s
s))
  (\ p e s
s p e b
b -> (Corep p e -> t) -> p e t
forall d c. (Corep p d -> c) -> p d c
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate (\ Corep p e
e -> Setter s t a b -> b -> s -> t
forall s t a b. Setter s t a b -> b -> s -> t
set Optic p s t a b
Lens s t a b
Setter s t a b
o (p e b -> Corep p e -> b
forall a b. p a b -> Corep p a -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve p e b
b Corep p e
e) (p e s -> Corep p e -> s
forall a b. p a b -> Corep p a -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve p e s
s Corep p e
e)))

devoid :: Lens Void Void a b
devoid :: forall a b (p :: * -> * -> *). IsLens p => Optic p Void Void a b
devoid = (Void -> a) -> (Void -> b -> Void) -> Lens Void Void a b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Void -> a
forall a. Void -> a
absurd Void -> b -> Void
forall a b. a -> b -> a
const

united :: Lens' a ()
united :: forall a (p :: * -> * -> *). IsLens p => Optic p a a () ()
united = (a -> ()) -> (a -> () -> a) -> Lens a a () ()
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (() -> a -> ()
forall a b. a -> b -> a
const ()) a -> () -> a
forall a b. a -> b -> a
const


-- Unpacked

-- | A 'Lens' unpacked into the get & set functions it was constructed from.
newtype UnpackedLens a b s t = UnpackedLens { forall a b s t.
UnpackedLens a b s t
-> forall r. ((s -> a) -> (s -> b -> t) -> r) -> r
withUnpackedLens :: forall r . ((s -> a) -> (s -> b -> t) -> r) -> r }

instance Profunctor (UnpackedLens a b) where
  dimap :: forall a b c d.
(a -> b)
-> (c -> d) -> UnpackedLens a b b c -> UnpackedLens a b a d
dimap a -> b
f c -> d
g (UnpackedLens forall r. ((b -> a) -> (b -> b -> c) -> r) -> r
r) = ((b -> a) -> (b -> b -> c) -> UnpackedLens a b a d)
-> UnpackedLens a b a d
forall r. ((b -> a) -> (b -> b -> c) -> r) -> r
r (((b -> a) -> (b -> b -> c) -> UnpackedLens a b a d)
 -> UnpackedLens a b a d)
-> ((b -> a) -> (b -> b -> c) -> UnpackedLens a b a d)
-> UnpackedLens a b a d
forall a b. (a -> b) -> a -> b
$ \ b -> a
get b -> b -> c
set -> (a -> a) -> (a -> b -> d) -> UnpackedLens a b a d
forall s a b t. (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t
unpackedLens (b -> a
get (b -> a) -> (a -> b) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) ((c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap c -> d
g ((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b -> c
set (b -> b -> c) -> (a -> b) -> a -> b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Strong (UnpackedLens a b) where
  first' :: forall a b c.
UnpackedLens a b a b -> UnpackedLens a b (a, c) (b, c)
first' (UnpackedLens forall r. ((a -> a) -> (a -> b -> b) -> r) -> r
r) = ((a -> a) -> (a -> b -> b) -> UnpackedLens a b (a, c) (b, c))
-> UnpackedLens a b (a, c) (b, c)
forall r. ((a -> a) -> (a -> b -> b) -> r) -> r
r (((a -> a) -> (a -> b -> b) -> UnpackedLens a b (a, c) (b, c))
 -> UnpackedLens a b (a, c) (b, c))
-> ((a -> a) -> (a -> b -> b) -> UnpackedLens a b (a, c) (b, c))
-> UnpackedLens a b (a, c) (b, c)
forall a b. (a -> b) -> a -> b
$ \ a -> a
get a -> b -> b
set -> ((a, c) -> a)
-> ((a, c) -> b -> (b, c)) -> UnpackedLens a b (a, c) (b, c)
forall s a b t. (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t
unpackedLens (a -> a
get (a -> a) -> ((a, c) -> a) -> (a, c) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, c) -> a
forall a b. (a, b) -> a
fst) (\ (a
a, c
c) b
b -> (a -> b -> b
set a
a b
b, c
c))

instance IsIso (UnpackedLens a b)
instance IsLens (UnpackedLens a b)


unpackedLens :: (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t
unpackedLens :: forall s a b t. (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t
unpackedLens s -> a
get s -> b -> t
set = (forall r. ((s -> a) -> (s -> b -> t) -> r) -> r)
-> UnpackedLens a b s t
forall a b s t.
(forall r. ((s -> a) -> (s -> b -> t) -> r) -> r)
-> UnpackedLens a b s t
UnpackedLens (\ (s -> a) -> (s -> b -> t) -> r
k -> (s -> a) -> (s -> b -> t) -> r
k s -> a
get s -> b -> t
set)