{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeFamilyDependencies    #-}
{-# LANGUAGE TypeOperators             #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Internal.Profunctor.Lens
-- Copyright   :  (C) 2020 Csongor Kiss
-- License     :  BSD3
-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Internal lens helpers. Only exported for Haddock
--
-----------------------------------------------------------------------------
module Data.Generics.Internal.Profunctor.Lens where

import Data.Profunctor.Indexed        (Profunctor(..), Strong(..))
import Data.Bifunctor
import GHC.Generics
import Data.Generics.Internal.Profunctor.Iso

type Lens s t a b
  = forall p i . Strong p => p i a b -> p i s t

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


ravel :: (ALens a b i a b -> ALens a b i s t) -> Lens s t a b
ravel :: (ALens a b i a b -> ALens a b i s t) -> Lens s t a b
ravel ALens a b i a b -> ALens a b i s t
l p i a b
pab = ALens a b i s t -> p i a b -> p i s t
forall a b i s t. ALens a b i s t -> Lens s t a b
conv (ALens a b i a b -> ALens a b i s t
l ALens a b i a b
forall a b i. ALens a b i a b
idLens) p i a b
pab
  where
    conv :: ALens a b i s t -> Lens s t a b
    conv :: ALens a b i s t -> Lens s t a b
conv (ALens s -> (c, a)
_get (c, b) -> t
_set) = (s -> (c, a)) -> ((c, b) -> t) -> Lens s t a b
forall s c a b t. (s -> (c, a)) -> ((c, b) -> t) -> Lens s t a b
lens s -> (c, a)
_get (c, b) -> t
_set

-- | Setting
set :: ((a -> b) -> s -> t) -> (s, b) -> t
set :: ((a -> b) -> s -> t) -> (s, b) -> t
set (a -> b) -> s -> t
f (s
s, b
b)
  = (a -> b) -> s -> t
f  (b -> a -> b
forall a b. a -> b -> a
const b
b) s
s

view :: Lens s s a a -> s -> a
view :: Lens s s a a -> s -> a
view Lens s s a a
l = Lens s s a a
-> (forall c. (s -> (c, a)) -> ((c, a) -> s) -> s -> a) -> s -> a
forall s t a b r.
Lens s t a b
-> (forall c. (s -> (c, a)) -> ((c, b) -> t) -> r) -> r
withLensPrim Lens s s a a
l (\s -> (c, a)
get (c, a) -> s
_ -> (c, a) -> a
forall a b. (a, b) -> b
snd ((c, a) -> a) -> (s -> (c, a)) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (c, a)
get)

--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
--ithLens l k =
-- case l idLens of
--   ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))

withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
withLensPrim :: Lens s t a b
-> (forall c. (s -> (c, a)) -> ((c, b) -> t) -> r) -> r
withLensPrim Lens s t a b
l forall c. (s -> (c, a)) -> ((c, b) -> t) -> r
k =
 case ALens a b Any a b -> ALens a b Any s t
Lens s t a b
l ALens a b Any a b
forall a b i. ALens a b i a b
idLens of
   ALens s -> (c, a)
_get (c, b) -> t
_set -> (s -> (c, a)) -> ((c, b) -> t) -> r
forall c. (s -> (c, a)) -> ((c, b) -> t) -> r
k s -> (c, a)
_get (c, b) -> t
_set

idLens :: ALens a b i a b
idLens :: ALens a b i a b
idLens = (a -> ((), a)) -> (((), b) -> b) -> ALens a b i a b
forall a b i s t c.
(s -> (c, a)) -> ((c, b) -> t) -> ALens a b i s t
ALens ((a -> ()) -> (a -> a) -> a -> ((), a)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
fork (() -> a -> ()
forall a b. a -> b -> a
const ()) a -> a
forall a. a -> a
id) ((), b) -> b
forall a b. (a, b) -> b
snd
{-# INLINE idLens #-}

-- | Lens focusing on the first element of a product
first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
first :: p i (a x) (a' x) -> p i ((:*:) a b x) ((:*:) a' b x)
first
  = ((:*:) a b x -> (b x, a x))
-> ((b x, a' x) -> (:*:) a' b x)
-> Lens ((:*:) a b x) ((:*:) a' b x) (a x) (a' x)
forall s c a b t. (s -> (c, a)) -> ((c, b) -> t) -> Lens s t a b
lens (\(a x
a :*: b x
b) -> (b x
b,a x
a)) (\(b x
b, a' x
a') -> a' x
a' a' x -> b x -> (:*:) a' b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b x
b)

-- | Lens focusing on the second element of a product
second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
second :: p i (b x) (b' x) -> p i ((:*:) a b x) ((:*:) a b' x)
second
  = ((:*:) a b x -> (a x, b x))
-> ((a x, b' x) -> (:*:) a b' x)
-> Lens ((:*:) a b x) ((:*:) a b' x) (b x) (b' x)
forall s c a b t. (s -> (c, a)) -> ((c, b) -> t) -> Lens s t a b
lens (\(a x
a :*: b x
b) -> (a x
a,b x
b)) (\(a x
a, b' x
b') -> a x
a a x -> b' x -> (:*:) a b' x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b' x
b')

fork :: (a -> b) -> (a -> c) -> a -> (b, c)
fork :: (a -> b) -> (a -> c) -> a -> (b, c)
fork a -> b
f a -> c
g a
a = (a -> b
f a
a, a -> c
g a
a)

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

data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)

instance Functor (Coyoneda f) where
  fmap :: (a -> b) -> Coyoneda f a -> Coyoneda f b
fmap a -> b
f (Coyoneda a -> a
g f a
fa)
    = (a -> b) -> f a -> Coyoneda f b
forall (f :: * -> *) b a. (a -> b) -> f a -> Coyoneda f b
Coyoneda (a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g) f a
fa

inj :: Functor f => Coyoneda f a -> f a
inj :: Coyoneda f a -> f a
inj (Coyoneda a -> a
f f a
a) = (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f f a
a

proj :: Functor f => f a -> Coyoneda f a
proj :: f a -> Coyoneda f a
proj f a
fa = (a -> a) -> f a -> Coyoneda f a
forall (f :: * -> *) b a. (a -> b) -> f a -> Coyoneda f b
Coyoneda a -> a
forall a. a -> a
id f a
fa

(??) :: Functor f => f (a -> b) -> a -> f b
f (a -> b)
fab ?? :: f (a -> b) -> a -> f b
?? a
a = ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) f (a -> b)
fab

assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
assoc3L :: p i (a, (b, c)) (a', (b', c')) -> p i ((a, b), c) ((a', b'), c')
assoc3L p i (a, (b, c)) (a', (b', c'))
f = p i (a, (b, c)) (a', (b', c')) -> p i ((a, b), c) ((a', b'), c')
forall a b c a' b' c'.
Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
assoc3 p i (a, (b, c)) (a', (b', c'))
f

stron :: (Either s s', b) -> Either (s, b) (s', b)
stron :: (Either s s', b) -> Either (s, b) (s', b)
stron (Either s s'
e, b
b) =  (s -> (s, b))
-> (s' -> (s', b)) -> Either s s' -> Either (s, b) (s', b)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (,b
b) (, b
b) Either s s'
e

choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
choosing :: Lens s t a b
-> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
choosing Lens s t a b
l Lens s' t' a b
r = Lens s t a b
-> (forall c.
    (s -> (c, a))
    -> ((c, b) -> t) -> p i a b -> p i (Either s s') (Either t t'))
-> p i a b
-> p i (Either s s') (Either t t')
forall s t a b r.
Lens s t a b
-> (forall c. (s -> (c, a)) -> ((c, b) -> t) -> r) -> r
withLensPrim Lens s t a b
l (\s -> (c, a)
getl (c, b) -> t
setl ->
                  Lens s' t' a b
-> (forall c.
    (s' -> (c, a))
    -> ((c, b) -> t') -> p i a b -> p i (Either s s') (Either t t'))
-> p i a b
-> p i (Either s s') (Either t t')
forall s t a b r.
Lens s t a b
-> (forall c. (s -> (c, a)) -> ((c, b) -> t) -> r) -> r
withLensPrim Lens s' t' a b
r (\s' -> (c, a)
getr (c, b) -> t'
setr ->
                            let --g :: Either s s' -> a
                                g :: Either s s' -> (Either c c, a)
g Either s s'
e = case Either s s'
e of
                                        Left s
v -> let (c
c, a
v') = s -> (c, a)
getl s
v in (c -> Either c c
forall a b. a -> Either a b
Left c
c, a
v')
                                        Right s'
v -> let (c
c, a
v') = s' -> (c, a)
getr s'
v in (c -> Either c c
forall a b. b -> Either a b
Right c
c, a
v')
                                s :: (Either c c, b) -> Either t t'
s = ((c, b) -> t)
-> ((c, b) -> t') -> Either (c, b) (c, b) -> Either t t'
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (c, b) -> t
setl (c, b) -> t'
setr (Either (c, b) (c, b) -> Either t t')
-> ((Either c c, b) -> Either (c, b) (c, b))
-> (Either c c, b)
-> Either t t'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either c c, b) -> Either (c, b) (c, b)
forall s s' b. (Either s s', b) -> Either (s, b) (s', b)
stron
                            in (Either s s' -> (Either c c, a))
-> ((Either c c, b) -> Either t t')
-> Lens (Either s s') (Either t t') a b
forall s c a b t. (s -> (c, a)) -> ((c, b) -> t) -> Lens s t a b
lens Either s s' -> (Either c c, a)
g (Either c c, b) -> Either t t'
s))

lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
lens :: (s -> (c, a)) -> ((c, b) -> t) -> Lens s t a b
lens s -> (c, a)
get (c, b) -> t
_set = (s -> (c, a)) -> ((c, b) -> t) -> p i (c, a) (c, b) -> p i s t
forall (p :: * -> * -> * -> *) a b c d i.
Profunctor p =>
(a -> b) -> (c -> d) -> p i b c -> p i a d
dimap s -> (c, a)
get (c, b) -> t
_set (p i (c, a) (c, b) -> p i s t)
-> (p i a b -> p i (c, a) (c, b)) -> p i a b -> p i s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p i a b -> p i (c, a) (c, b)
forall (p :: * -> * -> * -> *) i a b c.
Strong p =>
p i a b -> p i (c, a) (c, b)
second'
{-# INLINE lens #-}

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

data ALens a b i s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)

instance Functor (ALens a b i s) where
  fmap :: (a -> b) -> ALens a b i s a -> ALens a b i s b
fmap a -> b
f (ALens s -> (c, a)
_get (c, b) -> a
_set) = (s -> (c, a)) -> ((c, b) -> b) -> ALens a b i s b
forall a b i s t c.
(s -> (c, a)) -> ((c, b) -> t) -> ALens a b i s t
ALens s -> (c, a)
_get (a -> b
f (a -> b) -> ((c, b) -> a) -> (c, b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, b) -> a
_set)

instance Profunctor (ALens a b) where
  dimap :: (a -> b) -> (c -> d) -> ALens a b i b c -> ALens a b i a d
dimap a -> b
f c -> d
g (ALens b -> (c, a)
get (c, b) -> c
_set) = (a -> (c, a)) -> ((c, b) -> d) -> ALens a b i a d
forall a b i s t c.
(s -> (c, a)) -> ((c, b) -> t) -> ALens a b i s t
ALens (b -> (c, a)
get (b -> (c, a)) -> (a -> b) -> a -> (c, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (c -> d
g (c -> d) -> ((c, b) -> c) -> (c, b) -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, b) -> c
_set)
  lmap :: (a -> b) -> ALens a b i b c -> ALens a b i a c
lmap a -> b
f = (a -> b) -> (c -> c) -> ALens a b i b c -> ALens a b i a c
forall (p :: * -> * -> * -> *) a b c d i.
Profunctor p =>
(a -> b) -> (c -> d) -> p i b c -> p i a d
dimap a -> b
f c -> c
forall a. a -> a
id
  rmap :: (c -> d) -> ALens a b i b c -> ALens a b i b d
rmap c -> d
f = (b -> b) -> (c -> d) -> ALens a b i b c -> ALens a b i b d
forall (p :: * -> * -> * -> *) a b c d i.
Profunctor p =>
(a -> b) -> (c -> d) -> p i b c -> p i a d
dimap b -> b
forall a. a -> a
id c -> d
f

swap :: (a, b) -> (b, a)
swap :: (a, b) -> (b, a)
swap (a
x, b
y) = (b
y, a
x)

instance Strong (ALens a b) where
  first' :: ALens a b i a b -> ALens a b i (a, c) (b, c)
first' = ((a, c) -> (c, a))
-> ((c, b) -> (b, c))
-> ALens a b i (c, a) (c, b)
-> ALens a b i (a, c) (b, c)
forall (p :: * -> * -> * -> *) a b c d i.
Profunctor p =>
(a -> b) -> (c -> d) -> p i b c -> p i a d
dimap (a, c) -> (c, a)
forall a b. (a, b) -> (b, a)
swap (c, b) -> (b, c)
forall a b. (a, b) -> (b, a)
swap (ALens a b i (c, a) (c, b) -> ALens a b i (a, c) (b, c))
-> (ALens a b i a b -> ALens a b i (c, a) (c, b))
-> ALens a b i a b
-> ALens a b i (a, c) (b, c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALens a b i a b -> ALens a b i (c, a) (c, b)
forall (p :: * -> * -> * -> *) i a b c.
Strong p =>
p i a b -> p i (c, a) (c, b)
second'
  {-# INLINE first' #-}
  second' :: ALens a b i a b -> ALens a b i (c, a) (c, b)
second' (ALens a -> (c, a)
get (c, b) -> b
_set) = ((c, a) -> ((c, c), a))
-> (((c, c), b) -> (c, b)) -> ALens a b i (c, a) (c, b)
forall a b i s t c.
(s -> (c, a)) -> ((c, b) -> t) -> ALens a b i s t
ALens (c, a) -> ((c, c), a)
get' ((c, c), b) -> (c, b)
set'
    where
      get' :: (c, a) -> ((c, c), a)
get' (c
c, a
a1) = let (c
c1, a
a) = a -> (c, a)
get a
a1 in ((c
c, c
c1), a
a)
      set' :: ((c, c), b) -> (c, b)
set' ((c
c, c
c1), b
b) = (c
c, (c, b) -> b
_set (c
c1, b
b))
  {-# INLINE second' #-}