{-|
Module      : Prosidy.Optics.Internal
Description : Internal implementations of common Optics functions, removing a dependency on lens.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Safe #-}
module Prosidy.Optics.Internal
    ( module Prosidy.Optics.Internal
    , Profunctor(..)
    , Choice(..)
    , Strong(..)
    , Contravariant(..)
    )
where

import           Data.Profunctor                ( Profunctor(..)
                                                , Choice(..)
                                                , Strong(..)
                                                )
import           Data.Functor.Const             ( Const(..) )
import           Data.Monoid                    ( First(..)
                                                , Endo(..)
                                                )
import           Data.Functor.Identity          ( Identity(..) )
import           Data.Tagged                    ( Tagged(..) )
import           Data.Functor.Contravariant.Compat
                                                ( Contravariant(..) )

type Optic p f s t a b = p a (f b) -> p s (f t)
type Iso s t a b = forall p f . (Profunctor p, Functor f) => Optic p f s t a b
type Lens s t a b = forall p f . (Strong p, Functor f) => Optic p f s t a b
type Prism s t a b
    = forall p f . (Choice p, Applicative f) => Optic p f s t a b
type Affine s t a b
    = forall p f . (Choice p, Strong p, Applicative f) => Optic p f s t a b
type Traversal s t a b = forall f . (Applicative f) => Optic (->) f s t a b

type Optic' p f s a = Optic p f s s a a
type Iso' s a = Iso s s a a
type Lens' s a = Lens s s a a
type Prism' s a = Prism s s a a
type Affine' s a = Affine s s a a
type Traversal' s a = Traversal s s a a

type Getter s a = forall f . (Functor f, Contravariant f) => Optic' (->) f s a

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso get :: s -> a
get set :: b -> t
set = (s -> a) -> (f b -> f t) -> p a (f b) -> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
get ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
set)
{-# INLINE iso #-}

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get :: s -> a
get set :: s -> b -> t
set = (s -> (s, a))
-> ((s, f b) -> f t) -> p (s, a) (s, f b) -> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> (s, a)
into (s, f b) -> f t
forall (f :: * -> *). Functor f => (s, f b) -> f t
outof (p (s, a) (s, f b) -> p s (f t))
-> (p a (f b) -> p (s, a) (s, f b)) -> p a (f b) -> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (s, a) (s, f b)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second'
  where
    into :: s -> (s, a)
into x :: s
x = (s
x, s -> a
get s
x)
    outof :: (s, f b) -> f t
outof (x :: s
x, f :: f b
f) = (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> b -> t
set s
x) f b
f
{-# INLINE lens #-}

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism set :: b -> t
set get :: s -> Either t a
get = (s -> Either t a)
-> (Either t (f b) -> f t)
-> p (Either t a) (Either t (f b))
-> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
get Either t (f b) -> f t
rhs (p (Either t a) (Either t (f b)) -> p s (f t))
-> (p a (f b) -> p (Either t a) (Either t (f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either t a) (Either t (f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' where rhs :: Either t (f b) -> f t
rhs = (t -> f t) -> (f b -> f t) -> Either t (f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
set)
{-# INLINE prism #-}

prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' set :: b -> s
set get :: s -> Maybe a
get = (s -> Either s a)
-> (Either s (f b) -> f s)
-> p (Either s a) (Either s (f b))
-> p s (f s)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either s a
lhs Either s (f b) -> f s
rhs (p (Either s a) (Either s (f b)) -> p s (f s))
-> (p a (f b) -> p (Either s a) (Either s (f b)))
-> p a (f b)
-> p s (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either s a) (Either s (f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
  where
    lhs :: s -> Either s a
lhs x :: s
x = Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s a
forall a b. a -> Either a b
Left s
x) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
get s
x)
    rhs :: Either s (f b) -> f s
rhs = (s -> f s) -> (f b -> f s) -> Either s (f b) -> f s
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b -> s) -> f b -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> s
set)
{-# INLINE prism' #-}

affine :: (s -> Either t a) -> (s -> b -> t) -> Affine s t a b
affine :: (s -> Either t a) -> (s -> b -> t) -> Affine s t a b
affine get :: s -> Either t a
get set :: s -> b -> t
set = (s -> Either t (s, a))
-> (Either t (s, f b) -> f t)
-> p (Either t (s, a)) (Either t (s, f b))
-> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t (s, a)
lhs Either t (s, f b) -> f t
rhs (p (Either t (s, a)) (Either t (s, f b)) -> p s (f t))
-> (p a (f b) -> p (Either t (s, a)) (Either t (s, f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (s, a) (s, f b) -> p (Either t (s, a)) (Either t (s, f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' (p (s, a) (s, f b) -> p (Either t (s, a)) (Either t (s, f b)))
-> (p a (f b) -> p (s, a) (s, f b))
-> p a (f b)
-> p (Either t (s, a)) (Either t (s, f b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (s, a) (s, f b)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second'
  where
    lhs :: s -> Either t (s, a)
lhs x :: s
x = (a -> (s, a)) -> Either t a -> Either t (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s
x, ) (Either t a -> Either t (s, a)) -> Either t a -> Either t (s, a)
forall a b. (a -> b) -> a -> b
$ s -> Either t a
get s
x
    rhs :: Either t (s, f b) -> f t
rhs = (t -> f t) -> ((s, f b) -> f t) -> Either t (s, f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\(x :: s
x, f :: f b
f) -> s -> b -> t
set s
x (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
f)
{-# INLINE affine #-}

affine' :: (s -> Maybe a) -> (s -> b -> s) -> Affine s s a b
affine' :: (s -> Maybe a) -> (s -> b -> s) -> Affine s s a b
affine' get :: s -> Maybe a
get set :: s -> b -> s
set = (s -> Either s (s, a))
-> (Either s (s, f b) -> f s)
-> p (Either s (s, a)) (Either s (s, f b))
-> p s (f s)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either s (s, a)
lhs Either s (s, f b) -> f s
forall (f :: * -> *). Applicative f => Either s (s, f b) -> f s
rhs (p (Either s (s, a)) (Either s (s, f b)) -> p s (f s))
-> (p a (f b) -> p (Either s (s, a)) (Either s (s, f b)))
-> p a (f b)
-> p s (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (s, a) (s, f b) -> p (Either s (s, a)) (Either s (s, f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' (p (s, a) (s, f b) -> p (Either s (s, a)) (Either s (s, f b)))
-> (p a (f b) -> p (s, a) (s, f b))
-> p a (f b)
-> p (Either s (s, a)) (Either s (s, f b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (s, a) (s, f b)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second'
  where
    lhs :: s -> Either s (s, a)
lhs x :: s
x = Either s (s, a)
-> (a -> Either s (s, a)) -> Maybe a -> Either s (s, a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s (s, a)
forall a b. a -> Either a b
Left s
x) ((s, a) -> Either s (s, a)
forall a b. b -> Either a b
Right ((s, a) -> Either s (s, a))
-> (a -> (s, a)) -> a -> Either s (s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s
x, )) (Maybe a -> Either s (s, a)) -> Maybe a -> Either s (s, a)
forall a b. (a -> b) -> a -> b
$ s -> Maybe a
get s
x
    rhs :: Either s (s, f b) -> f s
rhs (Left  x :: s
x     ) = s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
x
    rhs (Right (x :: s
x, f :: f b
f)) = s -> b -> s
set s
x (b -> s) -> f b -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
f
{-# INLINE affine' #-}

nullAffine :: Affine s s a b
nullAffine :: Optic p f s s a b
nullAffine = (s -> Maybe a) -> (s -> b -> s) -> Affine s s a b
forall s a b. (s -> Maybe a) -> (s -> b -> s) -> Affine s s a b
affine' (Maybe a -> s -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) s -> b -> s
forall a b. a -> b -> a
const
{-# INLINE nullAffine #-}

to :: (s -> a) -> Getter s a
to :: (s -> a) -> Getter s a
to k :: s -> a
k = (s -> a) -> (f a -> f s) -> (a -> f a) -> s -> f s
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
k ((s -> a) -> f a -> f s
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap s -> a
k)
{-# INLINE to #-}

view :: Lens s t a b -> s -> a
view :: Lens s t a b -> s -> a
view f :: Lens s t a b
f = Const a t -> a
forall a k (b :: k). Const a b -> a
getConst (Const a t -> a) -> (s -> Const a t) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic (->) (Const a) s t a b
Lens s t a b
f a -> Const a b
forall k a (b :: k). a -> Const a b
Const
{-# INLINE view #-}

views :: Traversal s t a b -> s -> [a]
views :: Traversal s t a b -> s -> [a]
views f :: Traversal s t a b
f = (Endo [a] -> [a] -> [a]) -> [a] -> Endo [a] -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo [a] -> [a] -> [a]
forall a. Endo a -> a -> a
appEndo [] (Endo [a] -> [a]) -> (s -> Endo [a]) -> s -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (Endo [a]) t -> Endo [a]
forall a k (b :: k). Const a b -> a
getConst (Const (Endo [a]) t -> Endo [a])
-> (s -> Const (Endo [a]) t) -> s -> Endo [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic (->) (Const (Endo [a])) s t a b
Traversal s t a b
f (Endo [a] -> Const (Endo [a]) b
forall k a (b :: k). a -> Const a b
Const (Endo [a] -> Const (Endo [a]) b)
-> (a -> Endo [a]) -> a -> Const (Endo [a]) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (([a] -> [a]) -> Endo [a]) -> (a -> [a] -> [a]) -> a -> Endo [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:))
{-# INLINE views #-}

preview :: Optic (->) (Const (First a)) s t a b -> s -> Maybe a
preview :: Optic (->) (Const (First a)) s t a b -> s -> Maybe a
preview f :: Optic (->) (Const (First a)) s t a b
f = First a -> Maybe a
forall a. First a -> Maybe a
getFirst (First a -> Maybe a) -> (s -> First a) -> s -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (First a) t -> First a
forall a k (b :: k). Const a b -> a
getConst (Const (First a) t -> First a)
-> (s -> Const (First a) t) -> s -> First a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic (->) (Const (First a)) s t a b
f (First a -> Const (First a) b
forall k a (b :: k). a -> Const a b
Const (First a -> Const (First a) b)
-> (a -> First a) -> a -> Const (First a) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> (a -> Maybe a) -> a -> First a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
{-# INLINE preview #-}

over :: Optic (->) Identity s t a b -> (a -> b) -> s -> t
over :: Optic (->) Identity s t a b -> (a -> b) -> s -> t
over t :: Optic (->) Identity s t a b
t f :: 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
. Optic (->) Identity s t a b
t (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)
{-# INLINE over #-}

assign :: Optic' (->) Identity s a -> a -> s -> s
assign :: Optic' (->) Identity s a -> a -> s -> s
assign t :: Optic' (->) Identity s a
t = Optic' (->) Identity s a -> (a -> a) -> s -> s
forall s t a b. Optic (->) Identity s t a b -> (a -> b) -> s -> t
over Optic' (->) Identity s a
t ((a -> a) -> s -> s) -> (a -> a -> a) -> a -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a b. a -> b -> a
const
{-# INLINE assign #-}

review :: Prism' s a -> a -> s
review :: Prism' s a -> a -> s
review p :: Prism' s a
p = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (a -> Identity s) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged s (Identity s) -> Identity s
forall k (s :: k) b. Tagged s b -> b
unTagged (Tagged s (Identity s) -> Identity s)
-> (a -> Tagged s (Identity s)) -> a -> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic Tagged Identity s s a a
Prism' s a
p Optic Tagged Identity s s a a
-> (a -> Tagged a (Identity a)) -> a -> Tagged s (Identity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> Tagged a (Identity a)
forall k (s :: k) b. b -> Tagged s b
Tagged (Identity a -> Tagged a (Identity a))
-> (a -> Identity a) -> a -> Tagged a (Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity a
forall a. a -> Identity a
Identity
{-# INLINE review #-}