{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
#include "lens-common.h"
module Control.Lens.Prism
(
Prism, Prism'
, APrism, APrism'
, prism
, prism'
, withPrism
, clonePrism
, outside
, aside
, without
, below
, isn't
, matching
, matching'
, _Left
, _Right
, _Just
, _Nothing
, _Void
, _Show
, only
, nearly
, Prefixed(..)
, Suffixed(..)
, Choice(..)
) where
import Prelude ()
import Control.Applicative
import qualified Control.Lens.Internal.List as List
import Control.Lens.Internal.Prism
import Control.Lens.Internal.Prelude
import Control.Lens.Lens
import Control.Lens.Review
import Control.Lens.Type
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.List as List
import Data.Profunctor.Rep
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
type APrism' s a = APrism s s a a
withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism :: forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k (b -> t) -> (s -> Either t a) -> r
f = case coerce :: forall a b. Coercible a b => a -> b
coerce (APrism s t a b
k (forall a b s t. (b -> t) -> (s -> Either t a) -> Market a b s t
Market forall a. a -> Identity a
Identity forall a b. b -> Either a b
Right)) of
Market b -> t
bt s -> Either t a
seta -> (b -> t) -> (s -> Either t a) -> r
f b -> t
bt s -> Either t a
seta
{-# INLINE withPrism #-}
clonePrism :: APrism s t a b -> Prism s t a b
clonePrism :: forall s t a b. APrism s t a b -> Prism s t a b
clonePrism APrism s t a b
k = forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
sta -> forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> t
bt s -> Either t a
sta
{-# INLINE clonePrism #-}
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
bt s -> Either t a
seta = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (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' #-}
outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r)
outside :: forall (p :: * -> * -> *) s t a b r.
Representable p =>
APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r)
outside APrism s t a b
k = forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta p b r -> f (p a r)
f p t r
ft ->
p b r -> f (p a r)
f (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap b -> t
bt p t r
ft) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \p a r
fa -> forall (p :: * -> * -> *) d c.
Representable p =>
(d -> Rep p c) -> p d c
tabulate forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (p :: * -> * -> *) (f :: * -> *) a b.
Sieve p f =>
p a b -> a -> f b
sieve p t r
ft) (forall (p :: * -> * -> *) (f :: * -> *) a b.
Sieve p f =>
p a b -> a -> f b
sieve p a r
fa) forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either t a
seta
{-# INLINE outside #-}
without :: APrism s t a b
-> APrism u v c d
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
without :: forall s t a b u v c d.
APrism s t a b
-> APrism u v c d
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
without APrism s t a b
k APrism u v c d
k' =
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta ->
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism 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 #-}
aside :: APrism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside :: forall s t a b e.
APrism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside APrism s t a b
k =
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism 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 #-}
below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
below :: forall (f :: * -> *) s a.
Traversable f =>
APrism' s a -> Prism' (f s) (f a)
below APrism' s a
k =
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism' 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 #-}
isn't :: APrism s t a b -> s -> Bool
isn't :: forall s t a b. APrism s t a b -> s -> Bool
isn't APrism s t a b
k s
s =
case forall s t a b. APrism s t a b -> s -> Either t a
matching APrism s t a b
k s
s of
Left t
_ -> Bool
True
Right a
_ -> Bool
False
{-# INLINE isn't #-}
matching :: APrism s t a b -> s -> Either t a
matching :: forall s t a b. APrism s t a b -> s -> Either t a
matching APrism s t a b
k = forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k forall a b. (a -> b) -> a -> b
$ \b -> t
_ s -> Either t a
seta -> s -> Either t a
seta
{-# INLINE matching #-}
matching' :: LensLike (Either a) s t a b -> s -> Either t a
matching' :: forall a s t b. LensLike (Either a) s t a b -> s -> Either t a
matching' LensLike (Either a) s t a b
k = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. b -> Either a b
Right forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike (Either a) s t a b
k forall a b. a -> Either a b
Left
{-# INLINE matching' #-}
_Left :: Prism (Either a c) (Either b c) a b
_Left :: forall a c b. Prism (Either a c) (Either b c) a b
_Left = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. b -> Either a b
Right (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right)
{-# INLINE _Left #-}
_Right :: Prism (Either c a) (Either c b) a b
_Right :: forall c a b. Prism (Either c a) (Either c b) a b
_Right = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall a b. b -> Either a b
Right
{-# INLINE _Right #-}
_Just :: Prism (Maybe a) (Maybe b) a b
_Just :: forall a b. Prism (Maybe a) (Maybe b) a b
_Just = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a. Maybe a
Nothing) forall a b. b -> Either a b
Right
{-# INLINE _Just #-}
_Nothing :: Prism' (Maybe a) ()
_Nothing :: forall a. Prism' (Maybe a) ()
_Nothing = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just ()) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
{-# INLINE _Nothing #-}
_Void :: Prism s s a Void
_Void :: forall s a. Prism s s a Void
_Void = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism forall a. Void -> a
absurd forall a b. a -> Either a b
Left
{-# INLINE _Void #-}
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 #-}
_Show :: (Read a, Show a) => Prism' String a
_Show :: forall a. (Read a, Show a) => Prism' String a
_Show = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ \String
s -> case forall a. Read a => ReadS a
reads String
s of
[(a
a,String
"")] -> forall a b. b -> Either a b
Right a
a
[(a, String)]
_ -> forall a b. a -> Either a b
Left String
s
{-# INLINE _Show #-}
class Prefixed t where
prefixed :: t -> Prism' t t
instance Eq a => Prefixed [a] where
prefixed :: [a] -> Prism' [a] [a]
prefixed [a]
ps = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ([a]
ps forall a. [a] -> [a] -> [a]
++) (forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [a]
ps)
{-# INLINE prefixed #-}
instance Prefixed TS.Text where
prefixed :: Text -> Prism' Text Text
prefixed Text
p = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (Text
p forall a. Semigroup a => a -> a -> a
<>) (Text -> Text -> Maybe Text
TS.stripPrefix Text
p)
{-# INLINE prefixed #-}
instance Prefixed TL.Text where
prefixed :: Text -> Prism' Text Text
prefixed Text
p = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (Text
p forall a. Semigroup a => a -> a -> a
<>) (Text -> Text -> Maybe Text
TL.stripPrefix Text
p)
{-# INLINE prefixed #-}
instance Prefixed BS.ByteString where
prefixed :: ByteString -> Prism' ByteString ByteString
prefixed ByteString
p = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (ByteString
p forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
p)
{-# INLINE prefixed #-}
instance Prefixed BL.ByteString where
prefixed :: ByteString -> Prism' ByteString ByteString
prefixed ByteString
p = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (ByteString
p forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString -> Maybe ByteString
BL.stripPrefix ByteString
p)
{-# INLINE prefixed #-}
class Suffixed t where
suffixed :: t -> Prism' t t
instance Eq a => Suffixed [a] where
suffixed :: [a] -> Prism' [a] [a]
suffixed [a]
qs = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a. [a] -> [a] -> [a]
++ [a]
qs) (forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix [a]
qs)
{-# INLINE suffixed #-}
instance Suffixed TS.Text where
suffixed :: Text -> Prism' Text Text
suffixed Text
qs = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a. Semigroup a => a -> a -> a
<> Text
qs) (Text -> Text -> Maybe Text
TS.stripSuffix Text
qs)
{-# INLINE suffixed #-}
instance Suffixed TL.Text where
suffixed :: Text -> Prism' Text Text
suffixed Text
qs = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a. Semigroup a => a -> a -> a
<> Text
qs) (Text -> Text -> Maybe Text
TL.stripSuffix Text
qs)
{-# INLINE suffixed #-}
instance Suffixed BS.ByteString where
suffixed :: ByteString -> Prism' ByteString ByteString
suffixed ByteString
qs = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a. Semigroup a => a -> a -> a
<> ByteString
qs) (ByteString -> ByteString -> Maybe ByteString
BS.stripSuffix ByteString
qs)
{-# INLINE suffixed #-}
instance Suffixed BL.ByteString where
suffixed :: ByteString -> Prism' ByteString ByteString
suffixed ByteString
qs = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (forall a. Semigroup a => a -> a -> a
<> ByteString
qs) (ByteString -> ByteString -> Maybe ByteString
BL.stripSuffix ByteString
qs)
{-# INLINE suffixed #-}