-- |
-- 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',
  -- an 'Optics.AffineTraversal.AffineTraversal', 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
  -- 'Optics.AffineTraversal.matching' :: 'Prism' s t a b             -> s -> Either t a
  -- @
  --
  -- 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 :: forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> t
construct s -> Either t a
match = 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 a b. (a -> b) -> a -> b
$ 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 (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id b -> t
construct) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' :: forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' b -> s
bs s -> Maybe a
sma = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> s
bs (\s
s -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left s
s) 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 :: 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
o (b -> t) -> (s -> Either t a) -> r
k = case 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 (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) (forall a b i s t. (b -> t) -> (s -> Either t a) -> Market a b i s t
Market forall a. a -> a
id forall a b. b -> Either a b
Right) of
  Market b -> t
construct s -> Either t a
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 :: forall k (is :: IxList) s t a b e.
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
k =
  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     forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta ->
  forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt) forall a b. (a -> b) -> a -> b
$ \(e
e,s
s) ->
  case s -> Either t a
seta s
s of
    Left t
t  -> forall a b. a -> Either a b
Left  (e
e,t
t)
    Right a
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 :: forall k l (is :: IxList) s t a b u v c d.
(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
k =
  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         forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta Optic l is u v c d
k' ->
  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'        forall a b. (a -> b) -> a -> b
$ \d -> v
dv u -> Either v c
uevc    ->
  forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (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) forall a b. (a -> b) -> a -> b
$ \Either s u
su ->
  case Either s u
su of
    Left s
s  -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. a -> Either a b
Left forall a b. a -> Either a b
Left (s -> Either t a
seta s
s)
    Right u
u -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. b -> Either a b
Right 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 :: forall k (f :: * -> *) (is :: IxList) s a.
(Is k A_Prism, Traversable f) =>
Optic' k is s a -> Prism' (f s) (f a)
below Optic' k is s a
k =
  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     forall a b. (a -> b) -> a -> b
$ \a -> s
bt s -> Either s a
seta ->
  forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> s
bt) forall a b. (a -> b) -> a -> b
$ \f s
s ->
  case 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
_  -> forall a b. a -> Either a b
Left f s
s
    Right f a
t -> 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 :: forall a. Eq a => a -> Prism' a ()
only a
a = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\() -> a
a) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a 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 :: forall a. a -> (a -> Bool) -> Prism' a ()
nearly a
a a -> Bool
p = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\() -> a
a) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p
{-# INLINE nearly #-}

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