{-# OPTIONS_GHC -Wno-redundant-constraints #-}

{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}

{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

The @prolens@ package is a Haskell library with a minimal and lightweight
implementation of optics based on 'Profunctor's. __'Optic'__ is a high-level
concept for values that provide composable access to different parts of structures.

"Prolens" implements the following optics:

 * 'Lens' — composable getters and setters
 * 'Prism' — composable constructors and deconstructors
 * 'Traversal' — composable data structures visitors

== Usage

To use lenses or prisms in your project, you need to add @prolens@ package as
the dependency in the @build-depends@ field of your @.cabal@ file. E.g.:

@
build-depends: prolens ^>= 0.0.0.0
@

You should add the import of this module in the place of lenses usage:

@
__import__ "Prolens"
@

== Creating your own optics

We show in each section of this module how to create values of each
kind of optics.

⚠️ __The general crucial rule__ for achieving maximum performance:
always add @\{\-\# INLINE ... \#\-\}@ pragmas to your optics.

== Typeclasses table

The below table shows required constraints for each 'Optic':

+-------------+------------------------------+
| Optic       | Constraints                  |
+=============+==============================+
| 'Lens'      | @'Strong' p@                 |
+-------------+------------------------------+
| 'Prism'     | @'Choice' p@                 |
+-------------+------------------------------+
| 'Traversal' | @('Choice' p, 'Monoidal' p)@ |
+-------------+------------------------------+

== Usage table: get, set, modify

Here is a go-to table on how to use getter, setters and modifiers with different
'Optic's.

+-------------+------------------+--------------+------------------+------------------+-----------------+-----------------+
|             | get              | get operator | set              | set operator     | modify          | modify operator |
+=============+==================+==============+==================+==================+=================+=================+
| 'Lens'      | @'view' l x@     | @x '^.' l@   | @'set' l new x@  | @x & l '.~' new@ | @'over' l f x@  | @x & l '%~' f@  |
+-------------+------------------+--------------+------------------+------------------+-----------------+-----------------+
| 'Prism'     | @'preview' _L x@ | -            | @'set' _L new x@ | -                | @'over' _L f x@ | -               |
+-------------+------------------+--------------+------------------+------------------+-----------------+-----------------+
| 'Traversal' | @'view' l x@     | -            | @'set' l new x@  | -                | @'over' l f x@  | -               |
+-------------+------------------+--------------+------------------+------------------+-----------------+-----------------+

@since 0.0.0.0
-}

module Prolens
    ( -- * Profunctor typeclass
      Profunctor (..)

      -- * Optics
    , Optic

      -- * Lenses
      -- $lenses

      -- ** Lenses types
    , Lens
    , Lens'
      -- ** Strong typeclass
    , Strong (..)

      -- ** Lenses functions
    , set
    , over
    , view
    , lens

      -- ** Lenses operators
    , (^.)
    , (.~)
    , (%~)

      -- ** Standard lenses
    , fstL
    , sndL

      -- * Prisms
      -- $prisms

      -- ** Prism types
    , Prism
    , Prism'
      -- ** Choice typeclass
    , Choice (..)

      -- ** Prism functions
    , prism
    , prism'
    , preview

      -- ** Standard Prisms
    , _Just
    , _Left
    , _Right

      -- * Traversals

      -- ** Traversal types
    , Traversal
      -- ** Monoidal typeclass
    , Monoidal (..)

      -- ** Traversal functions
    , traverseOf

      -- ** Standard traversals
    , eachPair
    , eachMaybe
    , eachList

      -- * Internal data types
    , Forget (..)
    , Fun (..)
    ) where

import Control.Applicative (Const (..), liftA2)
import Data.Coerce (coerce)
import Data.Monoid (First (..))

-- $setup
-- >>> import Data.Function ((&))


{- | The type @p@ is called 'Profunctor' and it means, that a value of
type @p in out@ takes a value of type @in@ as an argument (input) and
outputs a value of type @out@. 'Profunctor' allows mapping of inputs
and outputs.

@
          +----> Result input
          |
          |                                +--> Original profunctor
          |      +-> Original input        |
          +      +                         +
dimap :: (in2 -> in1) -> (out1 -> out2) -> p in1 out1 -> p in2 out2
                          +       +
                          |       +-> Result output
                          |
                          +-> Original output
@

Speaking in terms of other abstractions, 'Profunctor' is
'Data.Functor.Contravariant.Contravariant' in the first type argument
(type variable @in@) and 'Functor' in the second type argument (type
variable @out@).

Moreover, @p in@ must have 'Functor' instance first to implement the
'Profunctor' instance. This required using @QuantifiedConstraints@.

@
                         Contravariant <---+
                                           |
                                         +-+-+
                                         +   +
(forall a . Functor (p a)) => Profunctor p a b
          +                              + +
          |                              | |
          +--> Quantified constraint     +++
                                          |
                              Functor  <--+
@

Instances of 'Profunctor' should satisfy the following laws:

* __Identity:__ @'dimap' 'id' 'id' ≡ 'id'@
* __Composition:__ @'dimap' (inAB . inBC) (outYZ . outXY) ≡ 'dimap' outBC outYZ . 'dimap' outAB outXY@

@since 0.0.0.0
-}
-- type Profunctor :: (Type -> Type -> Type) -> Constraint
class (forall a . Functor (p a)) => Profunctor p where
    dimap
        :: (in2 -> in1)  -- ^ Map input
        -> (out1 -> out2)  -- ^ Map output
        -> p in1 out1  -- ^ Take @in1@ as input and return @out1@
        -> p in2 out2  -- ^ Take @in2@ as input and return @out2@

-- | @since 0.0.0.0
instance Profunctor (->) where
    dimap :: (in2 -> in1) -> (out1 -> out2) -> (in1 -> out1) -> (in2 -> out2)
    dimap :: (in2 -> in1) -> (out1 -> out2) -> (in1 -> out1) -> in2 -> out2
dimap in2 -> in1
in21 out1 -> out2
out12 in1 -> out1
f = out1 -> out2
out12 (out1 -> out2) -> (in2 -> out1) -> in2 -> out2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. in1 -> out1
f (in1 -> out1) -> (in2 -> in1) -> in2 -> out1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. in2 -> in1
in21
    {-# INLINE dimap #-}

{- | @'Fun' m a b@ is a wrapper for function @a -> m b@.

@since 0.0.0.0
-}
newtype Fun m a b = Fun
    { Fun m a b -> a -> m b
unFun :: a -> m b
    }

-- | @since 0.0.0.0
instance Functor m => Functor (Fun m x) where
    fmap :: (a -> b) -> Fun m x a -> Fun m x b
    fmap :: (a -> b) -> Fun m x a -> Fun m x b
fmap a -> b
f (Fun x -> m a
xma) = (x -> m b) -> Fun m x b
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun ((a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> (x -> m a) -> x -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m a
xma)
    {-# INLINE fmap #-}

-- | @since 0.0.0.0
instance Functor m => Profunctor (Fun m) where
    dimap :: (in2 -> in1) -> (out1 -> out2) -> Fun m in1 out1 -> Fun m in2 out2
    dimap :: (in2 -> in1) -> (out1 -> out2) -> Fun m in1 out1 -> Fun m in2 out2
dimap in2 -> in1
in21 out1 -> out2
out12 (Fun in1 -> m out1
f) = (in2 -> m out2) -> Fun m in2 out2
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun ((out1 -> out2) -> m out1 -> m out2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap out1 -> out2
out12 (m out1 -> m out2) -> (in2 -> m out1) -> in2 -> m out2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. in1 -> m out1
f (in1 -> m out1) -> (in2 -> in1) -> in2 -> m out1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. in2 -> in1
in21)
    {-# INLINE dimap #-}

{- | 'Strong' is a 'Profunctor' that can be lifted to take a pair as
an input and return a pair.

The second element of a pair (variable of type @c@) can be of any
type, and you can decide what type it should be. This is convenient
for implementing various functions. E.g. 'lens' uses this fact.

@since 0.0.0.0
-}
class Profunctor p => Strong p where
    first  :: p a b -> p (a, c) (b, c)
    second :: p a b -> p (c, a) (c, b)

-- | @since 0.0.0.0
instance Strong (->) where
    first :: (a -> b) -> (a, c) -> (b, c)
    first :: (a -> b) -> (a, c) -> (b, c)
first a -> b
ab (a
a, c
c) = (a -> b
ab a
a, c
c)
    {-# INLINE first #-}

    second :: (a -> b) -> (c, a) -> (c, b)
    second :: (a -> b) -> (c, a) -> (c, b)
second a -> b
ab (c
c, a
a) = (c
c, a -> b
ab a
a)
    {-# INLINE second #-}

-- | @since 0.0.0.0
instance (Functor m) => Strong (Fun m) where
    first :: Fun m a b -> Fun m (a, c) (b, c)
    first :: Fun m a b -> Fun m (a, c) (b, c)
first (Fun a -> m b
amb) = ((a, c) -> m (b, c)) -> Fun m (a, c) (b, c)
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun (\(a
a, c
c) -> (b -> (b, c)) -> m b -> m (b, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, c
c) (a -> m b
amb a
a))
    {-# INLINE first #-}

    second :: Fun m a b -> Fun m (c, a) (c, b)
    second :: Fun m a b -> Fun m (c, a) (c, b)
second (Fun a -> m b
amb) = ((c, a) -> m (c, b)) -> Fun m (c, a) (c, b)
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun (\(c
c, a
a) -> (b -> (c, b)) -> m b -> m (c, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (c
c,) (a -> m b
amb a
a))
    {-# INLINE second #-}

{- | 'Choice' is a 'Profunctor' that can be lifted to work with
'Either' given input or some other value.

The other element of 'Either' (variable of type @c@) can be of any
type, and you can decide what type it should be. This is convenient
for implementing various functions. E.g. 'prism' uses this fact.

@since 0.0.0.0
-}
class Profunctor p => Choice p where
    left  :: p a b -> p (Either a c) (Either b c)
    right :: p a b -> p (Either c a) (Either c b)

-- | @since 0.0.0.0
instance Choice (->) where
    left  :: (a -> b) -> Either a c -> Either b c
    left :: (a -> b) -> Either a c -> Either b c
left a -> b
ab = \case
        Left a
a  -> b -> Either b c
forall a b. a -> Either a b
Left (b -> Either b c) -> b -> Either b c
forall a b. (a -> b) -> a -> b
$ a -> b
ab a
a
        Right c
c -> c -> Either b c
forall a b. b -> Either a b
Right c
c
    {-# INLINE left #-}

    right :: (a -> b) -> Either c a -> Either c b
    right :: (a -> b) -> Either c a -> Either c b
right a -> b
ab = \case
        Right a
a -> b -> Either c b
forall a b. b -> Either a b
Right (b -> Either c b) -> b -> Either c b
forall a b. (a -> b) -> a -> b
$ a -> b
ab a
a
        Left c
c  -> c -> Either c b
forall a b. a -> Either a b
Left c
c
    {-# INLINE right #-}

-- | @since 0.0.0.0
instance (Applicative m) => Choice (Fun m) where
    left :: Fun m a b -> Fun m (Either a c) (Either b c)
    left :: Fun m a b -> Fun m (Either a c) (Either b c)
left (Fun a -> m b
amb)= (Either a c -> m (Either b c)) -> Fun m (Either a c) (Either b c)
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun ((Either a c -> m (Either b c)) -> Fun m (Either a c) (Either b c))
-> (Either a c -> m (Either b c))
-> Fun m (Either a c) (Either b c)
forall a b. (a -> b) -> a -> b
$ \Either a c
eitherAc -> case Either a c
eitherAc of
        Left a
a  -> b -> Either b c
forall a b. a -> Either a b
Left (b -> Either b c) -> m b -> m (Either b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
amb a
a
        Right c
c -> Either b c -> m (Either b c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b c -> m (Either b c)) -> Either b c -> m (Either b c)
forall a b. (a -> b) -> a -> b
$ c -> Either b c
forall a b. b -> Either a b
Right c
c
    {-# INLINE left #-}

    right :: Fun m a b -> Fun m (Either c a) (Either c b)
    right :: Fun m a b -> Fun m (Either c a) (Either c b)
right (Fun a -> m b
amb)= (Either c a -> m (Either c b)) -> Fun m (Either c a) (Either c b)
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun ((Either c a -> m (Either c b)) -> Fun m (Either c a) (Either c b))
-> (Either c a -> m (Either c b))
-> Fun m (Either c a) (Either c b)
forall a b. (a -> b) -> a -> b
$ \Either c a
eitherCa -> case Either c a
eitherCa of
        Right a
a -> b -> Either c b
forall a b. b -> Either a b
Right (b -> Either c b) -> m b -> m (Either c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
amb a
a
        Left c
c  -> Either c b -> m (Either c b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either c b -> m (Either c b)) -> Either c b -> m (Either c b)
forall a b. (a -> b) -> a -> b
$ c -> Either c b
forall a b. a -> Either a b
Left c
c
    {-# INLINE right #-}

{- | 'Monoidal' is 'Strong' 'Profunctor' that can be appended. It is
similar to 'Monoid's but for higher-kinded types.

@since 0.0.0.0
-}
class Strong p => Monoidal p where
    pappend :: p a b -> p c d -> p (a, c) (b, d)
    pempty :: p a a

-- | @since 0.0.0.0
instance Monoidal (->) where
    pappend :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
    pappend :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
pappend a -> b
ab c -> d
cd (a
a, c
c) = (a -> b
ab a
a, c -> d
cd c
c)
    {-# INLINE pappend #-}

    pempty :: a -> a
    pempty :: a -> a
pempty = a -> a
forall a. a -> a
id
    {-# INLINE pempty #-}

-- | @since 0.0.0.0
instance (Applicative m) => Monoidal (Fun m) where
    pappend :: Fun m a b -> Fun m c d -> Fun m (a, c) (b, d)
    pappend :: Fun m a b -> Fun m c d -> Fun m (a, c) (b, d)
pappend (Fun a -> m b
amb) (Fun c -> m d
cmd) = ((a, c) -> m (b, d)) -> Fun m (a, c) (b, d)
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun (\(a
a, c
c) -> (b -> d -> (b, d)) -> m b -> m d -> m (b, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (a -> m b
amb a
a) (c -> m d
cmd c
c))
    {-# INLINE pappend #-}

    pempty :: Fun m a a
    pempty :: Fun m a a
pempty = (a -> m a) -> Fun m a a
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (a -> a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. a -> a
id)
    {-# INLINE pempty #-}

{- | 'Optic' takes a connection from @a@ to @b@ (represented as a
value of type @p a b@) and returns a connection from @source@ to
@target@ (represented as a value of type @p source target@).

@
           +---> Profunctor
           |
           | +----> Final input
           | |
           | |      +-> Final output
           | |      |
           + +      +
type Optic p source target a b
                           + +
                           | |
            Given input <--+ |
                             |
        Given output <-------+
@

@since 0.0.0.0
-}
type Optic p source target a b = p a b -> p source target


{- $lenses

== Example

To understand better how to use this library lets look at some simple example.
Let's say we have the user and address data types in our system:

>>> :{
data Address = Address
    { addressCountry :: String
    , addressCity    :: String
    , addressIndex   :: String
    } deriving (Show)
:}

>>> :{
data User = User
    { userName    :: String
    , userAge     :: Int
    , userAddress :: Address
    } deriving (Show)
:}

We can easily get fields of the @User@ and @Address@ types, but
setting values is inconvenient (especially for nested records). To
solve this problem, we can use lenses — composable getters and
setters. 'Lens' is a value, so we need to define lenses for fields of
our data types first.

To create the lens for the @userName@ field we can use 'lens' function and
manually writing getter and setter function:

>>> :{
nameL :: Lens' User String
nameL = lens getter setter
  where
    getter :: User -> String
    getter = userName
    setter :: User -> String -> User
    setter user newName = user {userName = newName}
:}

In this manner, we can create other lenses for our @User@ data type.
Usually, lenses are one-liners, and we can define them easily using lambda-functions.

>>> :{
ageL :: Lens' User Int
ageL = lens userAge (\u new -> u {userAge = new})
:}

>>> :{
addressL :: Lens' User Address
addressL = lens userAddress (\u new -> u {userAddress = new})
:}

We want to have lenses for accessing @Adress@ fields inside @User@, so we want to have the following values:

@
countryL :: 'Lens'' User 'String'
cityL    :: 'Lens'' User 'String'
indexL   :: 'Lens'' User 'String'
@

/Note:/ for lenses as @countryL@, @cityL@ etc., we are using composition of the
lenses for the @userAddress@ field. If we have

>>> :{
addressCityL :: Lens' Address String
addressCityL = lens addressCity (\a new -> a {addressCity = new})
:}

then

>>> cityL = addressL . addressCityL

Let's say we have some sample user

>>> :{
address = Address
    { addressCountry = "UK"
    , addressCity    = "London"
    , addressIndex   = "XXX"
    }
user :: User
user = User
    { userName = "John"
    , userAge  = 42
    , userAddress = address
    }
:}

To view the fields of the User data type we can use 'view' or '^.'

>>> view ageL user
42
>>> user ^. cityL
"London"

If we want to change any of the user's data, we should use 'set' or '.~'

>>> set nameL "Johnny" user
User {userName = "Johnny", userAge = 42, userAddress = Address {addressCountry = "UK", addressCity = "London", addressIndex = "XXX"}}
>>> user & cityL .~ "Bristol"
User {userName = "John", userAge = 42, userAddress = Address {addressCountry = "UK", addressCity = "Bristol", addressIndex = "XXX"}}

'over' or '%~' operator could be useful when, for example, you want to increase the age by one on the user's birthday:

>>> over ageL succ user
User {userName = "John", userAge = 43, userAddress = Address {addressCountry = "UK", addressCity = "London", addressIndex = "XXX"}}
>>> user & ageL %~ succ
User {userName = "John", userAge = 43, userAddress = Address {addressCountry = "UK", addressCity = "London", addressIndex = "XXX"}}
-}

{- | 'Lens' represents composable getters and setters.

'Lens' is an @'Optic' p@ with the 'Strong' constraint on the @p@ type variable.

@
          +---> Current object
          |
          |      +-> Final object
          |      |
          +      +
type Lens source target a b
                        + +
                        | |
       Current field <--+ |
                          |
      Final field <-------+
@

@since 0.0.0.0
-}
type Lens source target a b = forall p . Strong p => Optic p source target a b

{- | The monomorphic lenses which don't change the type of the container (or of
the value inside). It has a 'Strong' constraint, and it can be used whenever a
getter or a setter is needed.

  * @a@ is the type of the value inside of structure
  * @source@ is the type of the whole structure

For most use-cases it's enought to use this 'Lens'' instead of more general 'Lens'.

@since 0.0.0.0
-}
type Lens' source a = Lens source source a a

{- | Sets the given value to the structure using a setter.

@since 0.0.0.0
-}
set :: (p ~ (->))
    => Optic p source target a b  -- ^ 'Optic' that can be lens
    -> b  -- ^ Value to set
    -> source  -- ^ Object where we want to set value
    -> target  -- ^ Resulting object with @b@ set
set :: Optic p source target a b -> b -> source -> target
set Optic p source target a b
abst = Optic p source target a b
abst Optic p source target a b -> (b -> p a b) -> b -> p source target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> p a b
forall a b. a -> b -> a
const
{-# INLINE set #-}

{- | Applies the given function to the target.

@since 0.0.0.0
-}
over
    :: (p ~ (->))
    => Optic p source target a b  -- ^ 'Optic' that can be lens
    -> (a -> b)  -- ^ Field modification function
    -> source  -- ^ Object where we want to set value
    -> target  -- ^ Resulting object with the modified field
over :: Optic p source target a b -> (a -> b) -> source -> target
over = Optic p source target a b -> (a -> b) -> source -> target
forall a. a -> a
id
{-# INLINE over #-}

{- | Gets a value out of a structure using a getter.

@since 0.0.0.0
-}
view
    :: (p ~ Fun (Const a))
    => Optic p source target a b  -- ^ 'Optic' that can be lens
    -> source  -- ^ Object from which we want to get value
    -> a  -- ^ Field of @source@
view :: Optic p source target a b -> source -> a
view Optic p source target a b
opt = p source target -> source -> a
coerce (Optic p source target a b
opt ((a -> Const a b) -> Fun (Const a) a b
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun a -> Const a b
forall k a (b :: k). a -> Const a b
Const))
{-# INLINE view #-}
-- view opt = getConst . unFun (opt (Fun Const))
-- opt :: Fun (Const a) a b -> Fun (Const a) s t
-- opt :: (a -> Const a b) -> ( s -> Const a t)

{- | Creates 'Lens' from the getter and setter.

@since 0.0.0.0
-}
lens
    :: (source -> a)  -- ^ Getter
    -> (source -> b -> target)  -- ^ Setter
    -> Lens source target a b
lens :: (source -> a) -> (source -> b -> target) -> Lens source target a b
lens source -> a
getter source -> b -> target
setter = (source -> (source, a))
-> ((source, b) -> target)
-> p (source, a) (source, b)
-> p source target
forall (p :: * -> * -> *) in2 in1 out1 out2.
Profunctor p =>
(in2 -> in1) -> (out1 -> out2) -> p in1 out1 -> p in2 out2
dimap (\source
s -> (source
s, source -> a
getter source
s)) ((source -> b -> target) -> (source, b) -> target
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry source -> b -> target
setter) (p (source, a) (source, b) -> p source target)
-> (p a b -> p (source, a) (source, b)) -> p a b -> p source target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (source, a) (source, b)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second
{-# INLINE lens #-}

{- | The operator form of 'view' with the arguments flipped.

@since 0.0.0.0
-}
infixl 8 ^.
(^.) :: source -> Lens' source a -> a
source
s ^. :: source -> Lens' source a -> a
^. Lens' source a
l = Optic (Fun (Const a)) source source a a -> source -> a
forall (p :: * -> * -> *) a source target b.
(p ~ Fun (Const a)) =>
Optic p source target a b -> source -> a
view Optic (Fun (Const a)) source source a a
Lens' source a
l source
s
{-# INLINE (^.) #-}

{- | The operator form of 'set'.

@since 0.0.0.0
-}
infixr 4 .~
(.~) :: Lens' source a -> a -> source -> source
.~ :: Lens' source a -> a -> source -> source
(.~) = Lens' source a -> a -> source -> source
forall (p :: * -> * -> *) source target a b.
(p ~ (->)) =>
Optic p source target a b -> b -> source -> target
set
{-# INLINE (.~) #-}

{- | The operator form of 'over'.

@since 0.0.0.0
-}
infixr 4 %~
(%~) :: Lens' source a -> (a -> a) -> source -> source
%~ :: Lens' source a -> (a -> a) -> source -> source
(%~) = Lens' source a -> (a -> a) -> source -> source
forall (p :: * -> * -> *) source target a b.
(p ~ (->)) =>
Optic p source target a b -> (a -> b) -> source -> target
over
{-# INLINE (%~) #-}

{- | 'Lens'' for a tuple on the first argument.

>>> view fstL (42, "str")
42

@since 0.0.0.0
-}
fstL :: Lens (a, c) (b, c) a b
fstL :: Optic p (a, c) (b, c) a b
fstL = ((a, c) -> a) -> ((a, c) -> b -> (b, c)) -> Lens (a, c) (b, c) a b
forall source a b target.
(source -> a) -> (source -> b -> target) -> Lens source target a b
lens (a, c) -> a
forall a b. (a, b) -> a
fst (((a, c) -> b -> (b, c)) -> Lens (a, c) (b, c) a b)
-> ((a, c) -> b -> (b, c)) -> Lens (a, c) (b, c) a b
forall a b. (a -> b) -> a -> b
$ \(a
_, c
b) b
new -> (b
new, c
b)
{-# INLINE fstL #-}

{- | 'Lens'' for a tuple on the second argument.

>>> view sndL (42, "Hello")
"Hello"

@since 0.0.0.0
-}
sndL :: Lens (x, a) (x, b) a b
sndL :: Optic p (x, a) (x, b) a b
sndL = ((x, a) -> a) -> ((x, a) -> b -> (x, b)) -> Lens (x, a) (x, b) a b
forall source a b target.
(source -> a) -> (source -> b -> target) -> Lens source target a b
lens (x, a) -> a
forall a b. (a, b) -> b
snd (((x, a) -> b -> (x, b)) -> Lens (x, a) (x, b) a b)
-> ((x, a) -> b -> (x, b)) -> Lens (x, a) (x, b) a b
forall a b. (a -> b) -> a -> b
$ \(x
a, a
_) b
new -> (x
a, b
new)
{-# INLINE sndL #-}

{- $prisms
Prisms work with sum types.

== Example

Let's say we have the user data type in our system:

>>> :{
data Address = Address
    { addressCountry :: String
    , addressCity    :: String
    } deriving (Show)
:}

>>> :{
data Payload
    = NamePayload String
    | IdPayload Int
    | AddressPayload Address
    deriving (Show)
:}

To create the prism for each constructor we can use 'prism'' function and
manually writing getter and setter function:

/NOTE:/ The naming convention for prisms is the following:

@
_ConstructorName
@

>>> :{
_NamePayload :: Prism' Payload String
_NamePayload = prism' construct match
  where
    match :: Payload -> Maybe String
    match p = case p of
        NamePayload name -> Just name
        _otherPayload -> Nothing
    construct :: String -> Payload
    construct = NamePayload
:}

In this manner, we can create other prisms for our @Payload@ data type.

>>> :{
_IdPayload :: Prism' Payload Int
_IdPayload = prism' IdPayload $ \p -> case p of
    IdPayload i -> Just i
    _otherPayload -> Nothing
:}

>>> :{
_AddressPayload :: Prism' Payload Address
_AddressPayload = prism' AddressPayload $ \p -> case p of
    AddressPayload a -> Just a
    _otherPayload -> Nothing
:}

Let's say we have some sample payload

>>> :{
payloadName :: Payload
payloadName = NamePayload "Some name"
:}

To view the fields of the @Payload@ data type we can use 'preview'

>>> preview _NamePayload payloadName
Just "Some name"
>>> preview _IdPayload payloadName
Nothing

If we want to change any of the data, we should use 'set' or '.~' (just like in lenses)

>>> set _NamePayload "Johnny" payloadName
NamePayload "Johnny"
>>> set _IdPayload 3 payloadName
NamePayload "Some name"

Note, that you can easily compose lenses and prisms together:

>>> :{
address = Address
    { addressCountry = "UK"
    , addressCity    = "London"
    }
:}

>>> :{
addressCityL :: Lens' Address String
addressCityL = lens addressCity (\a new -> a {addressCity = new})
:}

>>> :{
payloadAddress :: Payload
payloadAddress = AddressPayload address
:}

>>> set _AddressPayload (address & addressCityL .~ "Bristol") payloadAddress
AddressPayload (Address {addressCountry = "UK", addressCity = "Bristol"})
-}

{- | 'Prism' represents composable constructors and deconstructors.

'Prism' is an @'Optic' p@ with 'Choice' constraint on the @p@ type
variable.

@
                   +---> Current object
                   |
                   |      +-> Final object
                   |      |
                   +      +
        type Prism source target a b
                                 + +
                                 | |
 Field in current constructor <--+ |
                                   |
Field in final constructor <-------+
@

@since 0.0.0.0
-}
type Prism source target a b = forall p . Choice p => Optic p source target a b

{- | The monomorphic prisms which don't change the type of the container (or of
the value inside).

  * @a@ is the value inside the particular constructor
  * @source@ is some sum type

@since 0.0.0.0
-}
type Prism' source a = Prism source source a a

{- | Newtype around function @a -> r@. It's called /forget/ because it
forgets about its last type variable.

@since 0.0.0.0
-}
newtype Forget r a b = Forget
    { Forget r a b -> a -> r
unForget :: a -> r
    }

-- | @since 0.0.0.0
instance Functor (Forget r x) where
    fmap :: (a -> b) -> Forget r x a -> Forget r x b
    fmap :: (a -> b) -> Forget r x a -> Forget r x b
fmap a -> b
_ = Forget r x a -> Forget r x b
coerce

-- | @since 0.0.0.0
instance Profunctor (Forget r) where
    dimap :: (a -> b) -> (c -> d) -> Forget r b c -> Forget r a d
    dimap :: (a -> b) -> (c -> d) -> Forget r b c -> Forget r a d
dimap a -> b
ab c -> d
_cd (Forget b -> r
br) = (a -> r) -> Forget r a d
forall r a b. (a -> r) -> Forget r a b
Forget (b -> r
br (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
ab)
    {-# INLINE dimap #-}

-- | @since 0.0.0.0
instance Strong (Forget r) where
    first :: Forget r a b -> Forget r (a, c) (b, c)
    first :: Forget r a b -> Forget r (a, c) (b, c)
first (Forget a -> r
ar) = ((a, c) -> r) -> Forget r (a, c) (b, c)
forall r a b. (a -> r) -> Forget r a b
Forget (a -> r
ar (a -> r) -> ((a, c) -> a) -> (a, c) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, c) -> a
forall a b. (a, b) -> a
fst)
    {-# INLINE first #-}

    second :: Forget r a b -> Forget r (c, a) (c, b)
    second :: Forget r a b -> Forget r (c, a) (c, b)
second (Forget a -> r
ar) = ((c, a) -> r) -> Forget r (c, a) (c, b)
forall r a b. (a -> r) -> Forget r a b
Forget (a -> r
ar (a -> r) -> ((c, a) -> a) -> (c, a) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, a) -> a
forall a b. (a, b) -> b
snd)
    {-# INLINE second #-}

-- | @since 0.0.0.0
instance Monoid r => Choice (Forget r) where
    left :: Forget r a b -> Forget r (Either a c) (Either b c)
    left :: Forget r a b -> Forget r (Either a c) (Either b c)
left (Forget a -> r
ar) = (Either a c -> r) -> Forget r (Either a c) (Either b c)
forall r a b. (a -> r) -> Forget r a b
Forget ((a -> r) -> (c -> r) -> Either a c -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> r
ar (r -> c -> r
forall a b. a -> b -> a
const r
forall a. Monoid a => a
mempty))
    {-# INLINE left #-}

    right :: Forget r a b -> Forget r (Either c a) (Either c b)
    right :: Forget r a b -> Forget r (Either c a) (Either c b)
right (Forget a -> r
ar) = (Either c a -> r) -> Forget r (Either c a) (Either c b)
forall r a b. (a -> r) -> Forget r a b
Forget ((c -> r) -> (a -> r) -> Either c a -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (r -> c -> r
forall a b. a -> b -> a
const r
forall a. Monoid a => a
mempty) a -> r
ar)
    {-# INLINE right #-}

-- | @since 0.0.0.0
instance (Monoid r) => Monoidal (Forget r) where
    pappend :: Forget r a b -> Forget r c d -> Forget r (a, c) (b, d)
    pappend :: Forget r a b -> Forget r c d -> Forget r (a, c) (b, d)
pappend (Forget a -> r
ar) (Forget c -> r
cr) = ((a, c) -> r) -> Forget r (a, c) (b, d)
forall r a b. (a -> r) -> Forget r a b
Forget (\(a
a, c
c) -> a -> r
ar a
a r -> r -> r
forall a. Semigroup a => a -> a -> a
<> c -> r
cr c
c)
    {-# INLINE pappend #-}

    pempty :: Forget r a a
    pempty :: Forget r a a
pempty = (a -> r) -> Forget r a a
forall r a b. (a -> r) -> Forget r a b
Forget (r -> a -> r
forall a b. a -> b -> a
const r
forall a. Monoid a => a
mempty)
    {-# INLINE pempty #-}

{- | Match a value from @source@ type.

@since 0.0.0.0
-}
preview
    :: forall a source p
    .  (p ~ Forget (First a))
    => Optic p source source a a  -- ^ 'Optic' that can be prism
    -> source  -- ^ Object (possible sum type)
    -> Maybe a  -- ^ Value of type @a@ from a specific constructor
preview :: Optic p source source a a -> source -> Maybe a
preview Optic p source source a a
paapss = p source source -> source -> Maybe a
coerce (Optic p source source a a
paapss p a a
Forget (First a) a a
wrap)
  where
    wrap :: Forget (First a) a a
    wrap :: Forget (First a) a a
wrap = (a -> Maybe a) -> Forget (First a) a a
coerce @(a -> Maybe a) @(Forget (First a) a a) a -> Maybe a
forall a. a -> Maybe a
Just
    {-# INLINE wrap #-}
{-# INLINE preview #-}
-- preview paapss = getFirst . unForget (paapss (Forget (First . Just)))
-- paapss :: Forget (First a) a a -> Forget (First a) source source
-- paapss :: (a -> First a) -> source -> First a
-- paapss :: (a -> Maybe a) -> source -> Maybe a

{- | Create 'Prism' from constructor and matching function.

@since 0.0.0.0
-}
prism
    :: (b -> target)  -- ^ Constructor
    -> (source -> Either target a)  -- ^ Matching function
    -> Prism source target a b
-- prism :: (b -> target) -> (source -> Either target a) -> p a b -> p source target
prism :: (b -> target)
-> (source -> Either target a) -> Prism source target a b
prism b -> target
ctor source -> Either target a
match = (source -> Either target a)
-> (Either target b -> target)
-> p (Either target a) (Either target b)
-> p source target
forall (p :: * -> * -> *) in2 in1 out1 out2.
Profunctor p =>
(in2 -> in1) -> (out1 -> out2) -> p in1 out1 -> p in2 out2
dimap source -> Either target a
match ((target -> target) -> (b -> target) -> Either target b -> target
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either target -> target
forall a. a -> a
id b -> target
ctor) (p (Either target a) (Either target b) -> p source target)
-> (p a b -> p (Either target a) (Either target b))
-> p a b
-> p source target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Either target a) (Either target b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right
{-# INLINE prism #-}

{- | Create monomorphic 'Prism'' from constructor and matching function.

@since 0.0.0.0
-}
prism'
    :: (a -> source)  -- ^ Constructor
    -> (source -> Maybe a)  -- ^ Matching function
    -> Prism' source a
prism' :: (a -> source) -> (source -> Maybe a) -> Prism' source a
prism' a -> source
ctor source -> Maybe a
match = (a -> source) -> (source -> Either source a) -> Prism' source a
forall b target source a.
(b -> target)
-> (source -> Either target a) -> Prism source target a b
prism a -> source
ctor (\source
s -> Either source a
-> (a -> Either source a) -> Maybe a -> Either source a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (source -> Either source a
forall a b. a -> Either a b
Left source
s) a -> Either source a
forall a b. b -> Either a b
Right (Maybe a -> Either source a) -> Maybe a -> Either source a
forall a b. (a -> b) -> a -> b
$ source -> Maybe a
match source
s)
{-# INLINE prism' #-}

{- | 'Prism' for a 'Just' of 'Maybe'.

>>> preview _Just (Just 42)
Just 42

>>> preview _Just Nothing
Nothing

@since 0.0.0.0
-}
_Just :: Prism (Maybe a) (Maybe b) a b
_Just :: Optic p (Maybe a) (Maybe b) a b
_Just = (b -> Maybe b)
-> (Maybe a -> Either (Maybe b) a) -> Prism (Maybe a) (Maybe b) a b
forall b target source a.
(b -> target)
-> (source -> Either target a) -> Prism source target a b
prism b -> Maybe b
forall a. a -> Maybe a
Just ((Maybe a -> Either (Maybe b) a) -> Prism (Maybe a) (Maybe b) a b)
-> (Maybe a -> Either (Maybe b) a) -> Prism (Maybe a) (Maybe b) a b
forall a b. (a -> b) -> a -> b
$ \case
    Just a
a  -> a -> Either (Maybe b) a
forall a b. b -> Either a b
Right a
a
    Maybe a
Nothing -> Maybe b -> Either (Maybe b) a
forall a b. a -> Either a b
Left Maybe b
forall a. Maybe a
Nothing
{-# INLINE _Just #-}


{- | 'Prism' for a 'Left' of 'Either'.

>>> preview _Left (Left 42)
Just 42

>>> preview _Left (Right "Hello")
Nothing

@since 0.0.0.0
-}
_Left :: Prism (Either a x) (Either b x) a b
_Left :: Optic p (Either a x) (Either b x) a b
_Left = (b -> Either b x)
-> (Either a x -> Either (Either b x) a)
-> Prism (Either a x) (Either b x) a b
forall b target source a.
(b -> target)
-> (source -> Either target a) -> Prism source target a b
prism b -> Either b x
forall a b. a -> Either a b
Left ((Either a x -> Either (Either b x) a)
 -> Prism (Either a x) (Either b x) a b)
-> (Either a x -> Either (Either b x) a)
-> Prism (Either a x) (Either b x) a b
forall a b. (a -> b) -> a -> b
$ \case
    Left a
l  -> a -> Either (Either b x) a
forall a b. b -> Either a b
Right a
l
    Right x
r -> Either b x -> Either (Either b x) a
forall a b. a -> Either a b
Left (Either b x -> Either (Either b x) a)
-> Either b x -> Either (Either b x) a
forall a b. (a -> b) -> a -> b
$ x -> Either b x
forall a b. b -> Either a b
Right x
r
{-# INLINE _Left #-}

{- | 'Prism' for a 'Left' of 'Either'.

>>> preview _Right (Left 42)
Nothing

>>> preview _Right (Right "Hello")
Just "Hello"

@since 0.0.0.0
-}
_Right :: Prism (Either x a) (Either x b) a b
_Right :: Optic p (Either x a) (Either x b) a b
_Right = (b -> Either x b)
-> (Either x a -> Either (Either x b) a)
-> Prism (Either x a) (Either x b) a b
forall b target source a.
(b -> target)
-> (source -> Either target a) -> Prism source target a b
prism b -> Either x b
forall a b. b -> Either a b
Right ((Either x a -> Either (Either x b) a)
 -> Prism (Either x a) (Either x b) a b)
-> (Either x a -> Either (Either x b) a)
-> Prism (Either x a) (Either x b) a b
forall a b. (a -> b) -> a -> b
$ \case
    Right a
a -> a -> Either (Either x b) a
forall a b. b -> Either a b
Right a
a
    Left x
x  -> Either x b -> Either (Either x b) a
forall a b. a -> Either a b
Left (Either x b -> Either (Either x b) a)
-> Either x b -> Either (Either x b) a
forall a b. (a -> b) -> a -> b
$ x -> Either x b
forall a b. a -> Either a b
Left x
x
{-# INLINE _Right #-}


{- | 'Traversal' provides composable ways to visit different parts of
a data structure.

'Traversal' is an @'Optic' p@ with the 'Choice' and 'Monoidal'
constraints on the @p@ type variable.

@
               +---> Current collection
               |
               |      +-> Final collection
               |      |
               +      +
type Traversal source target a b
                             + +
                             | |
          Current element <--+ |
                               |
         Final element <-------+
@

@since 0.0.0.0
-}
type Traversal source target a b
    = forall p
    . (Choice p, Monoidal p)
    => Optic p source target a b

{- | Traverse a data structure using given 'Traversal'.

>>> traverseOf eachPair putStrLn ("Hello", "World!")
Hello
World!
((),())

@since 0.0.0.0
-}
traverseOf
    :: (Applicative f, p ~ Fun f)
    => Optic p source target a b  -- ^ 'Optic' that can be a traversal
    -> (a -> f b)  -- ^ Traversing function
    -> source  -- ^ Data structure to traverse
    -> f target  -- ^ Traversing result
traverseOf :: Optic p source target a b -> (a -> f b) -> source -> f target
traverseOf Optic p source target a b
pabPst a -> f b
aFb = Fun f source target -> source -> f target
forall (m :: * -> *) a b. Fun m a b -> a -> m b
unFun (Optic p source target a b
pabPst ((a -> f b) -> Fun f a b
forall (m :: * -> *) a b. (a -> m b) -> Fun m a b
Fun a -> f b
aFb))
-- pabPst :: Fun f a b -> Fun f source target
-- pabPst :: (a -> f b) -> Fun f source target

{- | 'Traversal' for a pair of same type elements.

>>> over eachPair (+ 1) (3, 7)
(4,8)

@since 0.0.0.0
-}
eachPair :: Traversal (a, a) (b, b) a b
eachPair :: Optic p (a, a) (b, b) a b
eachPair p a b
pab = p a b -> Optic p (a, a) (b, b) a b
forall (p :: * -> * -> *) a b c d.
Monoidal p =>
p a b -> p c d -> p (a, c) (b, d)
pappend p a b
pab p a b
pab

{- | 'Traversal' for a 'Maybe'.

>>> over eachMaybe (+ 1) (Just 3)
Just 4
>>> over eachMaybe (+ 1) Nothing
Nothing

@since 0.0.0.0
-}
eachMaybe :: Traversal (Maybe a) (Maybe b) a b
eachMaybe :: Optic p (Maybe a) (Maybe b) a b
eachMaybe p a b
pab = (Maybe a -> Either a ())
-> (Either b () -> Maybe b)
-> p (Either a ()) (Either b ())
-> p (Maybe a) (Maybe b)
forall (p :: * -> * -> *) in2 in1 out1 out2.
Profunctor p =>
(in2 -> in1) -> (out1 -> out2) -> p in1 out1 -> p in2 out2
dimap Maybe a -> Either a ()
forall a. Maybe a -> Either a ()
maybeToEither Either b () -> Maybe b
forall a. Either a () -> Maybe a
eitherToMaybe (p a b -> p (Either a ()) (Either b ())
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left p a b
pab)
  where
    maybeToEither :: Maybe a -> Either a ()
    maybeToEither :: Maybe a -> Either a ()
maybeToEither = \case
        Just a
a  -> a -> Either a ()
forall a b. a -> Either a b
Left a
a
        Maybe a
Nothing -> () -> Either a ()
forall a b. b -> Either a b
Right ()

    eitherToMaybe :: Either a () -> Maybe a
    eitherToMaybe :: Either a () -> Maybe a
eitherToMaybe = \case
        Left a
a   -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
        Right () -> Maybe a
forall a. Maybe a
Nothing

{- | 'Traversal' for lists.

>>> over eachList (+ 1) [1..5]
[2,3,4,5,6]
>>> over eachList (+ 1) []
[]

@since 0.0.0.0
-}
eachList :: Traversal [a] [b] a b
eachList :: Optic p [a] [b] a b
eachList p a b
pab = ([a] -> Either (a, [a]) ())
-> (Either (b, [b]) () -> [b])
-> p (Either (a, [a]) ()) (Either (b, [b]) ())
-> p [a] [b]
forall (p :: * -> * -> *) in2 in1 out1 out2.
Profunctor p =>
(in2 -> in1) -> (out1 -> out2) -> p in1 out1 -> p in2 out2
dimap [a] -> Either (a, [a]) ()
forall a. [a] -> Either (a, [a]) ()
listToEither Either (b, [b]) () -> [b]
forall a. Either (a, [a]) () -> [a]
eitherToList (p (Either (a, [a]) ()) (Either (b, [b]) ()) -> p [a] [b])
-> p (Either (a, [a]) ()) (Either (b, [b]) ()) -> p [a] [b]
forall a b. (a -> b) -> a -> b
$ p (a, [a]) (b, [b]) -> p (Either (a, [a]) ()) (Either (b, [b]) ())
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left (p (a, [a]) (b, [b])
 -> p (Either (a, [a]) ()) (Either (b, [b]) ()))
-> p (a, [a]) (b, [b])
-> p (Either (a, [a]) ()) (Either (b, [b]) ())
forall a b. (a -> b) -> a -> b
$ p a b -> p [a] [b] -> p (a, [a]) (b, [b])
forall (p :: * -> * -> *) a b c d.
Monoidal p =>
p a b -> p c d -> p (a, c) (b, d)
pappend p a b
pab (Optic p [a] [b] a b
forall a b. Traversal [a] [b] a b
eachList p a b
pab)
  where
    listToEither :: [a] -> Either (a, [a]) ()
    listToEither :: [a] -> Either (a, [a]) ()
listToEither = \case
        []   -> () -> Either (a, [a]) ()
forall a b. b -> Either a b
Right ()
        a
x:[a]
xs -> (a, [a]) -> Either (a, [a]) ()
forall a b. a -> Either a b
Left (a
x, [a]
xs)

    eitherToList :: Either (a, [a]) () -> [a]
    eitherToList :: Either (a, [a]) () -> [a]
eitherToList = \case
        Right ()     -> []
        Left (a
x, [a]
xs) -> a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs