-- |
-- Module: Optics.Prism
-- Description: A generalised or first-class constructor.
--
-- A 'Prism' generalises the notion of a constructor (just as a
-- 'Optics.Lens.Lens' generalises the notion of a field).
--
module Optics.Prism
  (
  -- * Formation
    Prism
  , Prism'

  -- * Introduction
  , prism

  -- * Elimination
  -- | A 'Prism' is in particular an 'Optics.AffineFold.AffineFold', a
  -- 'Optics.Review.Review' and a 'Optics.Setter.Setter', therefore you can
  -- specialise types to obtain:
  --
  -- @
  -- 'Optics.AffineFold.preview' :: 'Prism'' s a -> s -> Maybe a
  -- 'Optics.Review.review'  :: 'Prism'' s a -> a -> s
  -- @
  --
  -- @
  -- 'Optics.Setter.over'    :: 'Prism' s t a b -> (a -> b) -> s -> t
  -- 'Optics.Setter.set'     :: 'Prism' s t a b ->       b  -> s -> t
  -- @
  --
  -- If you want to 'Optics.AffineFold.preview' a type-modifying 'Prism' that is
  -- insufficiently polymorphic to be used as a type-preserving 'Prism'', use
  -- 'Optics.ReadOnly.getting':
  --
  -- @
  -- 'Optics.AffineFold.preview' . 'Optics.ReadOnly.getting' :: 'Prism' s t a b -> s -> 'Maybe' a
  -- @

  -- * Computation
  -- |
  --
  -- @
  -- 'Optics.Review.review'   ('prism' f g) ≡ f
  -- 'Optics.AffineTraversal.matching' ('prism' f g) ≡ g
  -- @

  -- * Well-formedness
  -- |
  --
  -- @
  -- 'Optics.AffineTraversal.matching' o ('Optics.Review.review' o b) ≡ 'Right' b
  -- 'Optics.AffineTraversal.matching' o s ≡ 'Right' a  =>  'Optics.Review.review' o a ≡ s
  -- @

  -- * Additional introduction forms
  -- | See "Data.Maybe.Optics" and "Data.Either.Optics" for 'Prism's for the
  -- corresponding types, and 'Optics.Cons.Core._Cons', 'Optics.Cons.Core._Snoc'
  -- and 'Optics.Empty.Core._Empty' for 'Prism's for container types.
  , prism'
  , only
  , nearly

  -- * Additional elimination forms
  , withPrism

  -- * Combinators
  , aside
  , without
  , below

  -- * Subtyping
  , A_Prism
  -- | <<diagrams/Prism.png Prism in the optics hierarchy>>
  )
  where

import Control.Monad
import Data.Bifunctor

import Data.Profunctor.Indexed

import Optics.Internal.Optic

-- | Type synonym for a type-modifying prism.
type Prism s t a b = Optic A_Prism NoIx s t a b

-- | Type synonym for a type-preserving prism.
type Prism' s a = Optic' A_Prism NoIx s a

-- | Build a prism from a constructor and a matcher, which must respect the
-- well-formedness laws.
--
-- If you want to build a 'Prism' from the van Laarhoven representation, use
-- @prismVL@ from the @optics-vl@ package.
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 b -> t
construct s -> Either t a
match = (forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ A_Prism p i (Curry NoIx i) s t a b)
-> Prism s t a b
forall k (is :: IxList) s t a b.
(forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ k p i (Curry is i) s t a b)
-> Optic k is s t a b
Optic ((forall (p :: * -> * -> * -> *) i.
  Profunctor p =>
  Optic_ A_Prism p i (Curry NoIx i) s t a b)
 -> Prism s t a b)
-> (forall (p :: * -> * -> * -> *) i.
    Profunctor p =>
    Optic_ A_Prism p i (Curry NoIx i) s t a b)
-> Prism s t a b
forall a b. (a -> b) -> a -> b
$ (s -> Either t a)
-> (Either t b -> t) -> p i (Either t a) (Either t 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 -> Either t a
match ((t -> t) -> (b -> t) -> Either t b -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> t
forall a. a -> a
id b -> t
construct) (p i (Either t a) (Either t b) -> p i s t)
-> (p i a b -> p i (Either t a) (Either t 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 (Either t a) (Either t b)
forall (p :: * -> * -> * -> *) i a b c.
Choice p =>
p i a b -> p i (Either c a) (Either c b)
right'
{-# INLINE prism #-}

-- | This is usually used to build a 'Prism'', when you have to use an operation
-- like 'Data.Typeable.cast' which already returns a 'Maybe'.
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' b -> s
bs s -> Maybe a
sma = (b -> s) -> (s -> Either s a) -> Prism s s a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> s
bs (\s
s -> 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
s) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
sma s
s))
{-# INLINE prism' #-}

-- | Work with a 'Prism' as a constructor and a matcher.
withPrism
  :: Is k A_Prism
  => Optic k is s t a b
  -> ((b -> t) -> (s -> Either t a) -> r)
  -> r
withPrism :: Optic k is s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Optic k is s t a b
o (b -> t) -> (s -> Either t a) -> r
k = case Optic A_Prism is s t a b
-> Optic__ (Market a b) Any (Curry is Any) s t a b
forall (p :: * -> * -> * -> *) k (is :: IxList) s t a b i.
Profunctor p =>
Optic k is s t a b -> Optic_ k p i (Curry is i) s t a b
getOptic (Optic k is s t a b -> Optic A_Prism is s t a b
forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic @A_Prism Optic k is s t a b
o) ((b -> b) -> (a -> Either b a) -> Market a b Any a b
forall a b i s t. (b -> t) -> (s -> Either t a) -> Market a b i s t
Market b -> b
forall a. a -> a
id a -> Either b a
forall a b. b -> Either a b
Right) of
  Market construct match -> (b -> t) -> (s -> Either t a) -> r
k b -> t
construct s -> Either t a
match
{-# INLINE withPrism #-}

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

-- | Use a 'Prism' to work over part of a structure.
aside :: Is k A_Prism => Optic k is s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside :: Optic k is s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside Optic k is s t a b
k =
  Optic k is s t a b
-> ((b -> t)
    -> (s -> Either t a) -> Prism (e, s) (e, t) (e, a) (e, b))
-> Prism (e, s) (e, t) (e, a) (e, b)
forall k (is :: IxList) s t a b r.
Is k A_Prism =>
Optic k is s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Optic k is s t a b
k     (((b -> t)
  -> (s -> Either t a) -> Prism (e, s) (e, t) (e, a) (e, b))
 -> Prism (e, s) (e, t) (e, a) (e, b))
-> ((b -> t)
    -> (s -> Either t a) -> Prism (e, s) (e, t) (e, a) (e, b))
-> Prism (e, s) (e, t) (e, a) (e, b)
forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta ->
  ((e, b) -> (e, t))
-> ((e, s) -> Either (e, t) (e, a))
-> Prism (e, s) (e, t) (e, a) (e, b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((b -> t) -> (e, b) -> (e, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt) (((e, s) -> Either (e, t) (e, a))
 -> Prism (e, s) (e, t) (e, a) (e, b))
-> ((e, s) -> Either (e, t) (e, a))
-> Prism (e, s) (e, t) (e, a) (e, b)
forall a b. (a -> b) -> a -> b
$ \(e
e,s
s) ->
  case s -> Either t a
seta s
s of
    Left t
t  -> (e, t) -> Either (e, t) (e, a)
forall a b. a -> Either a b
Left  (e
e,t
t)
    Right a
a -> (e, a) -> Either (e, t) (e, a)
forall a b. b -> Either a b
Right (e
e,a
a)
{-# INLINE aside #-}

-- | Given a pair of prisms, project sums.
--
-- Viewing a 'Prism' as a co-'Optics.Lens.Lens', this combinator can be seen to
-- be dual to 'Optics.Lens.alongside'.
without
  :: (Is k A_Prism, Is l A_Prism)
  => Optic k is s t a b
  -> Optic l is u v c d
  -> Prism (Either s u) (Either t v) (Either a c) (Either b d)
without :: Optic k is s t a b
-> Optic l is u v c d
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
without Optic k is s t a b
k =
  Optic k is s t a b
-> ((b -> t)
    -> (s -> Either t a)
    -> Optic l is u v c d
    -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> Optic l is u v c d
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
forall k (is :: IxList) s t a b r.
Is k A_Prism =>
Optic k is s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Optic k is s t a b
k         (((b -> t)
  -> (s -> Either t a)
  -> Optic l is u v c d
  -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
 -> Optic l is u v c d
 -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> ((b -> t)
    -> (s -> Either t a)
    -> Optic l is u v c d
    -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> Optic l is u v c d
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta Optic l is u v c d
k' ->
  Optic l is u v c d
-> ((d -> v)
    -> (u -> Either v c)
    -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
forall k (is :: IxList) s t a b r.
Is k A_Prism =>
Optic k is s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Optic l is u v c d
k'        (((d -> v)
  -> (u -> Either v c)
  -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
 -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> ((d -> v)
    -> (u -> Either v c)
    -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
forall a b. (a -> b) -> a -> b
$ \d -> v
dv u -> Either v c
uevc    ->
  (Either b d -> Either t v)
-> (Either s u -> Either (Either t v) (Either a c))
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((b -> t) -> (d -> v) -> Either b d -> Either t v
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> t
bt d -> v
dv) ((Either s u -> Either (Either t v) (Either a c))
 -> Prism (Either s u) (Either t v) (Either a c) (Either b d))
-> (Either s u -> Either (Either t v) (Either a c))
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
forall a b. (a -> b) -> a -> b
$ \Either s u
su ->
  case Either s u
su of
    Left s
s  -> (t -> Either t v)
-> (a -> Either a c)
-> Either t a
-> Either (Either t v) (Either a c)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap t -> Either t v
forall a b. a -> Either a b
Left a -> Either a c
forall a b. a -> Either a b
Left (s -> Either t a
seta s
s)
    Right u
u -> (v -> Either t v)
-> (c -> Either a c)
-> Either v c
-> Either (Either t v) (Either a c)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap v -> Either t v
forall a b. b -> Either a b
Right c -> Either a c
forall a b. b -> Either a b
Right (u -> Either v c
uevc u
u)
{-# INLINE without #-}

-- | Lift a 'Prism' through a 'Traversable' functor, giving a 'Prism' that
-- matches only if all the elements of the container match the 'Prism'.
below
  :: (Is k A_Prism, Traversable f)
  => Optic' k is s a
  -> Prism' (f s) (f a)
below :: Optic' k is s a -> Prism' (f s) (f a)
below Optic' k is s a
k =
  Optic' k is s a
-> ((a -> s) -> (s -> Either s a) -> Prism' (f s) (f a))
-> Prism' (f s) (f a)
forall k (is :: IxList) s t a b r.
Is k A_Prism =>
Optic k is s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Optic' k is s a
k     (((a -> s) -> (s -> Either s a) -> Prism' (f s) (f a))
 -> Prism' (f s) (f a))
-> ((a -> s) -> (s -> Either s a) -> Prism' (f s) (f a))
-> Prism' (f s) (f a)
forall a b. (a -> b) -> a -> b
$ \a -> s
bt s -> Either s a
seta ->
  (f a -> f s) -> (f s -> Either (f s) (f a)) -> Prism' (f s) (f a)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> s
bt) ((f s -> Either (f s) (f a)) -> Prism' (f s) (f a))
-> (f s -> Either (f s) (f a)) -> Prism' (f s) (f a)
forall a b. (a -> b) -> a -> b
$ \f s
s ->
  case (s -> Either s a) -> f s -> Either s (f a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse s -> Either s a
seta f s
s of
    Left s
_  -> f s -> Either (f s) (f a)
forall a b. a -> Either a b
Left f s
s
    Right f a
t -> f a -> Either (f s) (f a)
forall a b. b -> Either a b
Right f a
t
{-# INLINE below #-}

-- | This 'Prism' compares for exact equality with a given value.
--
-- >>> only 4 # ()
-- 4
--
-- >>> 5 ^? only 4
-- Nothing
only :: Eq a => a -> Prism' a ()
only :: a -> Prism' a ()
only a
a = (() -> a) -> (a -> Maybe ()) -> Prism' a ()
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\() -> a
a) ((a -> Maybe ()) -> Prism' a ()) -> (a -> Maybe ()) -> Prism' a ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (a -> Bool) -> a -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)
{-# INLINE only #-}

-- | This 'Prism' compares for approximate equality with a given value and a
-- predicate for testing, an example where the value is the empty list and the
-- predicate checks that a list is empty (same as 'Optics.Empty._Empty' with the
-- 'Optics.Empty.AsEmpty' list instance):
--
-- >>> nearly [] null # ()
-- []
-- >>> [1,2,3,4] ^? nearly [] null
-- Nothing
--
-- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@
--
-- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are
-- somewhat constrained.
--
-- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid
-- 'Prism'.
--
-- This is useful when working with a type where you can test equality for only
-- a subset of its values, and the prism selects such a value.
nearly :: a -> (a -> Bool) -> Prism' a ()
nearly :: a -> (a -> Bool) -> Prism' a ()
nearly a
a a -> Bool
p = (() -> a) -> (a -> Maybe ()) -> Prism' a ()
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\() -> a
a) ((a -> Maybe ()) -> Prism' a ()) -> (a -> Maybe ()) -> Prism' a ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (a -> Bool) -> a -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p
{-# INLINE nearly #-}

-- $setup
-- >>> import Optics.Core