module Optics.Prism
(
Prism
, Prism'
, prism
, prism'
, only
, nearly
, withPrism
, aside
, without
, below
, A_Prism
)
where
import Control.Monad
import Data.Bifunctor
import Data.Profunctor.Indexed
import Optics.Internal.Optic
type Prism s t a b = Optic A_Prism NoIx s t a b
type Prism' s a = Optic' A_Prism NoIx s a
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 #-}
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' #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}