summaryrefslogtreecommitdiff
path: root/src/Data/Profunctor/Optic/Prism.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Profunctor/Optic/Prism.hs')
-rw-r--r--src/Data/Profunctor/Optic/Prism.hs695
1 files changed, 301 insertions, 394 deletions
diff --git a/src/Data/Profunctor/Optic/Prism.hs b/src/Data/Profunctor/Optic/Prism.hs
index 5d55302..a6d796b 100644
--- a/src/Data/Profunctor/Optic/Prism.hs
+++ b/src/Data/Profunctor/Optic/Prism.hs
@@ -1,61 +1,139 @@
-module Data.Profunctor.Optic.Prism where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Prism (
+ -- * Prism & Cxprism
+ Prism
+ , Prism'
+ , Cxprism
+ , Cxprism'
+ , APrism
+ , APrism'
+ , prism
+ , prism'
+ , cxprism
+ , handling
+ , clonePrism
+ -- * Coprism & Ixprism
+ , Coprism
+ , Coprism'
+ , Ixprism
+ , Ixprism'
+ , ACoprism
+ , ACoprism'
+ , coprism
+ , coprism'
+ , rehandling
+ , cloneCoprism
+ -- * Optics
+ , l1
+ , r1
+ , left
+ , right
+ , cxright
+ , just
+ , nothing
+ , cxjust
+ , keyed
+ , filtered
+ , compared
+ , prefixed
+ , only
+ , nearly
+ , nthbit
+ , sync
+ , async
+ , exception
+ , asyncException
+ -- * Primitive operators
+ , withPrism
+ , withCoprism
+ -- * Operators
+ , aside
+ , without
+ , below
+ , toPastroSum
+ , toTambaraSum
+ -- * Carriers
+ , PrismRep(..)
+ , CoprismRep(..)
+ -- * Classes
+ , Choice(..)
+ , Cochoice(..)
+) where
import Control.Exception
import Control.Monad (guard)
+import Data.Bifunctor as B
+import Data.Bits (Bits, bit, testBit)
+import Data.List (stripPrefix)
+import Data.Prd
+import Data.Profunctor.Choice
import Data.Profunctor.Optic.Iso
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
-import GHC.IO.Exception
-import qualified Control.Exception as Ex
+
+import GHC.Generics hiding (from, to)
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTypeOperators
+-- >>> :set -XRankNTypes
+-- >>> import Data.Int.Instance ()
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let catchFoo :: b -> Cxprism String (String + a) (String + b) a b; catchFoo b = cxright $ \e k -> if e == "fooError" && k == mempty then Right b else Left e
---------------------------------------------------------------------
--- 'Prism'
+-- 'Prism' & 'Cxprism'
---------------------------------------------------------------------
--- | Build a 'Choice' optic from a constructor and a matcher function.
+-- | Obtain a 'Prism' from a constructor and a matcher function.
--
--- \( \quad \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \)
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions satisfy the following
+-- properties:
--
--- /Caution/: In order for the generated prism family to be well-defined,
--- you must ensure that the three prism laws hold:
+-- * @sta (bt b) ≡ Right b@
--
--- * @seta (bt b) ≡ Right b@
+-- * @(id ||| bt) (sta s) ≡ s@
--
--- * @(id ||| bt) (seta s) ≡ s@
+-- * @left sta (sta s) ≡ left Left (sta s)@
+--
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @left seta (seta s) ≡ left Left (seta s)@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
-- See 'Data.Profunctor.Optic.Property'.
--
prism :: (s -> t + a) -> (b -> t) -> Prism s t a b
-prism seta bt = dimap seta (id ||| bt) . pright
+prism sta bt = dimap sta (id ||| bt) . right'
--- | Create a 'Prism' from a reviewer and a matcher function that produces a 'Maybe'.
+-- | Obtain a 'Prism'' from a reviewer and a matcher function that produces a 'Maybe'.
--
prism' :: (s -> Maybe a) -> (a -> s) -> Prism' s a
-prism' sma as = flip prism as $ \s -> maybe (Left s) Right (sma s)
+prism' sa as = flip prism as $ \s -> maybe (Left s) Right (sa s)
--- | Build a 'Prism' from its free tensor representation.
+-- | Obtain a 'Cxprism'' from a reviewer and a matcher function that returns either a match or a failure handler.
--
--- Useful for constructing prisms from try and handle functions.
---
-handling :: (s -> e + a) -> (e + b -> t) -> Prism s t a b
-handling sea ebt = dimap sea ebt . pright
+cxprism :: (s -> (k -> t) + a) -> (b -> t) -> Cxprism k s t a b
+cxprism skta bt = prism skta (bt .)
--- | Build a 'Cochoice' optic from a constructor and a matcher function.
+-- | Obtain a 'Prism' from its free tensor representation.
--
--- * @reprism f g ≡ \f g -> re (prism f g)@
---
--- * @view . re $ prism bat _ ≡ bat@
---
--- * @matchOf . re . re $ prism _ sa ≡ sa@
---
--- A 'Reprism' is a 'View', so you can specialise types to obtain:
---
--- @ view :: 'Reprism'' s a -> s -> a @
+-- Useful for constructing prisms from try and handle functions.
--
-reprism :: (b -> a + t) -> (s -> a) -> Reprism s t a b
-reprism beat sa = unright . dimap (id ||| sa) beat
+handling :: (s -> c + a) -> (c + b -> t) -> Prism s t a b
+handling sca cbt = dimap sca cbt . right'
-- | TODO: Document
--
@@ -63,461 +141,290 @@ clonePrism :: APrism s t a b -> Prism s t a b
clonePrism o = withPrism o prism
---------------------------------------------------------------------
--- 'PrismRep'
----------------------------------------------------------------------
-
-type APrism s t a b = Optic (PrismRep a b) s t a b
-
-type APrism' s a = APrism s s a a
-
--- | The 'PrismRep' profunctor precisely characterizes a 'Prism'.
-data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)
-
-instance Functor (PrismRep a b s) where
-
- fmap f (PrismRep seta bt) = PrismRep (either (Left . f) Right . seta) (f . bt)
- {-# INLINE fmap #-}
-
-instance Profunctor (PrismRep a b) where
-
- dimap f g (PrismRep seta bt) = PrismRep (either (Left . g) Right . seta . f) (g . bt)
- {-# INLINE dimap #-}
-
- lmap f (PrismRep seta bt) = PrismRep (seta . f) bt
- {-# INLINE lmap #-}
-
- rmap f (PrismRep seta bt) = PrismRep (either (Left . f) Right . seta) (f . bt)
- {-# INLINE rmap #-}
-
-instance Choice (PrismRep a b) where
-
- left' (PrismRep seta bt) = PrismRep (either (either (Left . Left) Right . seta) (Left . Right)) (Left . bt)
- {-# INLINE left' #-}
-
- right' (PrismRep seta bt) = PrismRep (either (Left . Left) (either (Left . Right) Right . seta)) (Right . bt)
- {-# INLINE right' #-}
-
----------------------------------------------------------------------
--- Primitive operators
+-- 'Coprism' & 'Ixprism'
---------------------------------------------------------------------
--- | TODO: Document
+-- | Obtain a 'Cochoice' optic from a constructor and a matcher function.
--
-withPrism :: APrism s t a b -> ((s -> t + a) -> (b -> t) -> r) -> r
-withPrism o f = case o (PrismRep Right id) of PrismRep g h -> f g h
-
--- | Analogous to @(+++)@ from 'Control.Arrow'
+-- @
+-- coprism f g ≡ \f g -> re (prism f g)
+-- @
--
-splitting :: Prism s1 t1 a1 b1 -> Prism s2 t2 a2 b2 -> Prism (s1 + s2) (t1 + t2) (a1 + a2) (b1 + b2)
-splitting = split
-
--- | TODO: Document
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions satisfy the following
+-- properties:
--
-prismr :: (s -> t + a) -> (b -> t) -> Prism (c + s) (d + t) (c + a) (d + b)
-prismr f g = between runSplit Split (prism f g)
-
--- | Use a 'Prism' to lift part of a structure.
+-- * @bat (bt b) ≡ Right b@
--
-aside :: APrism s t a b -> Prism (e , s) (e , t) (e , a) (e , b)
-aside k =
- withPrism k $ \seta bt ->
- flip prism (fmap bt) $ \(e,s) ->
- case seta s of
- Left t -> Left (e,t)
- Right a -> Right (e,a)
-{-# INLINE aside #-}
-
--- | Given a pair of prisms, project sums.
-without :: APrism s t a b -> APrism u v c d -> Prism (s + u) (t + v) (a + c) (b + d)
-without k =
- withPrism k $ \seta bt k' ->
- withPrism k' $ \uevc dv ->
- flip prism (bimap bt dv) $ \su ->
- case su of
- Left s -> bimap Left Left (seta s)
- Right u -> bimap Right Right (uevc 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'.
+-- * @(id ||| bt) (bat b) ≡ b@
--
--- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below _R
--- []
+-- * @left bat (bat b) ≡ left Left (bat b)@
--
--- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below _R
--- [["hail hydra!","foo","blah","woot"]]
+-- A 'Coprism' is a 'View', so you can specialise types to obtain:
--
-below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
-below k =
- withPrism k $ \seta bt ->
- flip prism (fmap bt) $ \s ->
- case traverse seta s of
- Left _ -> Left s
- Right t -> Right t
-{-# INLINE below #-}
-
----------------------------------------------------------------------
--- Common prisms
----------------------------------------------------------------------
-
--- | TODO: Document
+-- @ view :: 'Coprism'' s a -> s -> a @
--
-_L :: Prism (a + c) (b + c) a b
-_L = pleft
+coprism :: (s -> a) -> (b -> a + t) -> Coprism s t a b
+coprism sa bat = unright . dimap (id ||| sa) bat
--- | TODO: Document
+-- | Create a 'Coprism' from a reviewer and a matcher function that produces a 'Maybe'.
--
-_R :: Prism (c + a) (c + b) a b
-_R = pright
+coprism' :: (s -> a) -> (a -> Maybe s) -> Coprism' s a
+coprism' tb bt = coprism tb $ \b -> maybe (Left b) Right (bt b)
--- | Prism for the `Just` constructor of `Maybe`.
+-- | Obtain a 'Coprism' from its free tensor representation.
--
-_Just :: Prism (Maybe a) (Maybe b) a b
-_Just = flip prism Just $ maybe (Left Nothing) Right
-
--- | Prism for the `Nothing` constructor of `Maybe`.
---
-_Nothing :: Prism (Maybe a) (Maybe b) () ()
-_Nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing)
+rehandling :: (c + s -> a) -> (b -> c + t) -> Coprism s t a b
+rehandling csa bct = unright . dimap csa bct
-- | TODO: Document
--
-lowerL :: Iso s t (a + c) (b + c) -> Prism s t a b
-lowerL = (. _L)
+cloneCoprism :: ACoprism s t a b -> Coprism s t a b
+cloneCoprism o = withCoprism o coprism
--- | TODO: Document
---
-lowerR :: Iso s t (c + a) (c + b) -> Prism s t a b
-lowerR = (. _R)
+---------------------------------------------------------------------
+-- Common 'Prism's and 'Coprism's
+---------------------------------------------------------------------
--- | Obtain a 'Prism' that can be composed with to filter another 'Lens', 'Iso', 'View', 'Fold' (or 'Traversal').
---
--- >>> [1..10] ^.. folded . filtered even
--- [2,4,6,8,10]
---
-filtered :: (a -> Bool) -> Prism' a a
-filtered f = iso (branch' f) dedup . _R
+l1 :: Prism ((a :+: c) t) ((b :+: c) t) (a t) (b t)
+l1 = prism sta L1
+ where
+ sta (L1 v) = Right v
+ sta (R1 v) = Left (R1 v)
+{-# INLINE l1 #-}
--- | TODO: Document
---
-selected :: Eq a => a -> Prism' (a , b) b
-selected x = flip prism ((,) x) $ \kv@(k,v) -> branch (==x) kv v k
+r1 :: Prism ((c :+: a) t) ((c :+: b) t) (a t) (b t)
+r1 = prism sta R1
+ where
+ sta (R1 v) = Right v
+ sta (L1 v) = Left (L1 v)
+{-# INLINE r1 #-}
--- | Create a 'Prism' from a value and a predicate.
+-- | 'Prism' into the `Left` constructor of `Either`.
--
-nearly :: a -> (a -> Bool) -> Prism' a ()
-nearly x f = prism' (guard . f) (const x)
+left :: Prism (a + c) (b + c) a b
+left = left'
--- | Focus not just on a case, but a specific value of that case.
+-- | 'Prism' into the `Right` constructor of `Either`.
--
-only :: Eq a => a -> Prism' a ()
-only x = nearly x (x==)
+right :: Prism (c + a) (c + b) a b
+right = right'
--- | TODO: Document
+-- | Coindexed prism into the `Right` constructor of `Either`.
--
-lessThan :: Bounded a => Ord a => a -> Prism' a Ordering
-lessThan x = flip prism' (const x) $ \x' -> if x' < x then Just LT else Nothing
-
--- | TODO: Document
+-- >>> cxset (catchFoo "Caught foo") id $ Left "fooError"
+-- Right "Caught foo"
+-- >>> cxset (catchFoo "Caught foo") id $ Left "barError"
+-- Left "barError"
--
-excepted :: Exception a => Prism' SomeException a
-excepted = prism' fromException toException
+cxright :: (e -> k -> e + b) -> Cxprism k (e + a) (e + b) a b
+cxright ekeb = flip cxprism Right $ either (Left . ekeb) Right
--- | Exceptions that occur in the 'IO' 'Monad'.
---
--- An 'IOException' records a more specific error type, a descriptive string and possibly the handle
--- that was used when the error was flagged.
+-- | 'Prism' into the `Just` constructor of `Maybe`.
--
-_IOException :: Prism' SomeException IOException
-_IOException = excepted
+just :: Prism (Maybe a) (Maybe b) a b
+just = flip prism Just $ maybe (Left Nothing) Right
-----------------------------------------------------------------------------------------------------
--- IO Error Types
-----------------------------------------------------------------------------------------------------
-
--- | TODO: Document
+-- | 'Prism' into the `Nothing` constructor of `Maybe`.
--
-_AlreadyExists :: Prism' IOErrorType ()
-_AlreadyExists = only AlreadyExists
+nothing :: Prism (Maybe a) (Maybe b) () ()
+nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing)
--- | TODO: Document
+-- | Coindexed prism into the `Just` constructor of `Maybe`.
--
-_NoSuchThing :: Prism' IOErrorType ()
-_NoSuchThing = only NoSuchThing
-
--- | TODO: Document
+-- >>> Just "foo" & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "0: foo"
--
-_ResourceBusy :: Prism' IOErrorType ()
-_ResourceBusy = only ResourceBusy
-
--- | TODO: Document
+-- >>> Nothing & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Nothing
--
-_ResourceExhausted :: Prism' IOErrorType ()
-_ResourceExhausted = only ResourceExhausted
-
--- | TODO: Document
+-- >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "caught"
--
-_EOF :: Prism' IOErrorType ()
-_EOF = only EOF
+cxjust :: (k -> Maybe b) -> Cxprism k (Maybe a) (Maybe b) a b
+cxjust kb = flip cxprism Just $ maybe (Left kb) Right
--- | TODO: Document
---
-_IllegalOperation :: Prism' IOErrorType ()
-_IllegalOperation = only IllegalOperation
-
--- | TODO: Document
---
-_PermissionDenied :: Prism' IOErrorType ()
-_PermissionDenied = only PermissionDenied
-
--- | TODO: Document
+-- | Match a given key to obtain the associated value.
--
-_UserError :: Prism' IOErrorType ()
-_UserError = only UserError
+keyed :: Eq a => a -> Prism' (a , b) b
+keyed x = flip prism ((,) x) $ \kv@(k,v) -> branch (==x) kv v k
--- | TODO: Document
+-- | Filter another optic.
--
-_UnsatisfiedConstraints :: Prism' IOErrorType ()
-_UnsatisfiedConstraints = only UnsatisfiedConstraints
-
--- | TODO: Document
+-- >>> [1..10] ^.. folded . filtered even
+-- [2,4,6,8,10]
--
-_SystemError :: Prism' IOErrorType ()
-_SystemError = only SystemError
+filtered :: (a -> Bool) -> Prism' a a
+filtered f = iso (branch' f) join . right
--- | TODO: Document
+-- | Focus on comparability to a given element of a partial order.
--
-_ProtocolError :: Prism' IOErrorType ()
-_ProtocolError = only ProtocolError
+compared :: Eq a => Prd a => a -> Prism' a Ordering
+compared x = flip prism' (const x) (pcompare x)
--- | TODO: Document
+-- | 'Prism' into the remainder of a list with a given prefix.
--
-_OtherError :: Prism' IOErrorType ()
-_OtherError = only OtherError
+prefixed :: Eq a => [a] -> Prism' [a] [a]
+prefixed ps = prism' (stripPrefix ps) (ps ++)
--- | TODO: Document
+-- | Focus not just on a case, but a specific value of that case.
--
-_InvalidArgument :: Prism' IOErrorType ()
-_InvalidArgument = only InvalidArgument
+only :: Eq a => a -> Prism' a ()
+only x = nearly x (x==)
--- | TODO: Document
+-- | Create a 'Prism' from a value and a predicate.
--
-_InappropriateType :: Prism' IOErrorType ()
-_InappropriateType = only InappropriateType
+nearly :: a -> (a -> Bool) -> Prism' a ()
+nearly x f = prism' (guard . f) (const x)
--- | TODO: Document
+-- | Focus on the truth value of the nth bit in a bit array.
--
-_HardwareFault :: Prism' IOErrorType ()
-_HardwareFault = only HardwareFault
+nthbit :: Bits s => Int -> Prism' s ()
+nthbit n = prism' (guard . (flip testBit n)) (const $ bit n)
--- | TODO: Document
+-- | Check whether an exception is synchronous.
--
-_UnsupportedOperation :: Prism' IOErrorType ()
-_UnsupportedOperation = only UnsupportedOperation
+sync :: Exception e => Prism' e e
+sync = filtered $ \e -> case fromException (toException e) of
+ Just (SomeAsyncException _) -> False
+ Nothing -> True
--- | TODO: Document
+-- | Check whether an exception is asynchronous.
--
-_TimeExpired :: Prism' IOErrorType ()
-_TimeExpired = only TimeExpired
+async :: Exception e => Prism' e e
+async = filtered $ \e -> case fromException (toException e) of
+ Just (SomeAsyncException _) -> True
+ Nothing -> False
-- | TODO: Document
--
-_ResourceVanished :: Prism' IOErrorType ()
-_ResourceVanished = only ResourceVanished
+exception :: Exception e => Prism' SomeException e
+exception = prism' fromException toException
-- | TODO: Document
--
-_Interrupted :: Prism' IOErrorType ()
-_Interrupted = only Interrupted
+asyncException :: Exception e => Prism' SomeException e
+asyncException = prism' asyncExceptionFromException asyncExceptionToException
-----------------------------------------------------------------------------------------------------
--- Async Exceptions
-----------------------------------------------------------------------------------------------------
+---------------------------------------------------------------------
+-- Primitive operators
+---------------------------------------------------------------------
--- | The current thread's stack exceeded its limit. Since an 'Exception' has
--- been raised, the thread's stack will certainly be below its limit again,
--- but the programmer should take remedial action immediately.
+-- | Extract the two functions that characterize a 'Prism'.
--
-_StackOverflow :: Prism' AsyncException ()
-_StackOverflow = dimap seta (either id id) . right' . rmap (const Ex.StackOverflow)
- where seta Ex.StackOverflow = Right ()
- seta t = Left t
+withPrism :: APrism s t a b -> ((s -> t + a) -> (b -> t) -> r) -> r
+withPrism o f = case o (PrismRep Right id) of PrismRep g h -> f g h
--- | The program's heap usage has exceeded its limit.
+-- | Extract the two functions that characterize a 'Coprism'.
--
--- See 'GHC.IO.Exception' for more information.
---
-_HeapOverflow :: Prism' AsyncException ()
-_HeapOverflow = dimap seta (either id id) . right' . rmap (const Ex.HeapOverflow)
- where seta Ex.HeapOverflow = Right ()
- seta t = Left t
+withCoprism :: ACoprism s t a b -> ((s -> a) -> (b -> a + t) -> r) -> r
+withCoprism o f = case o (CoprismRep id Right) of CoprismRep g h -> f g h
--- | This 'Exception' is raised by another thread calling
--- 'Control.Concurrent.killThread', or by the system if it needs to terminate
--- the thread for some reason.
---
-_ThreadKilled :: Prism' AsyncException ()
-_ThreadKilled = dimap seta (either id id) . right' . rmap (const Ex.ThreadKilled)
- where seta Ex.ThreadKilled = Right ()
- seta t = Left t
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
--- | This 'Exception' is raised by default in the main thread of the program when
--- the user requests to terminate the program via the usual mechanism(s)
--- (/e.g./ Control-C in the console).
+-- | Use a 'Prism' to lift part of a structure.
--
-_UserInterrupt :: Prism' AsyncException ()
-_UserInterrupt = dimap seta (either id id) . right' . rmap (const Ex.UserInterrupt)
- where seta Ex.UserInterrupt = Right ()
- seta t = Left t
+aside :: APrism s t a b -> Prism (e , s) (e , t) (e , a) (e , b)
+aside k =
+ withPrism k $ \sta bt ->
+ flip prism (fmap bt) $ \(e,s) ->
+ case sta s of
+ Left t -> Left (e,t)
+ Right a -> Right (e,a)
+{-# INLINE aside #-}
-----------------------------------------------------------------------------------------------------
--- Arithmetic exceptions
-----------------------------------------------------------------------------------------------------
+-- | Given a pair of prisms, project sums.
+without :: APrism s t a b -> APrism u v c d -> Prism (s + u) (t + v) (a + c) (b + d)
+without k =
+ withPrism k $ \sta bt k' ->
+ withPrism k' $ \uevc dv ->
+ flip prism (bimap bt dv) $ \su ->
+ case su of
+ Left s -> bimap Left Left (sta s)
+ Right u -> bimap Right Right (uevc u)
+{-# INLINE without #-}
--- | Detect arithmetic overflow.
+-- | Lift a 'Prism' through a 'Traversable' functor.
+--
+-- Returns a 'Prism' that matches only if each element matches the original 'Prism'.
--
-_Overflow :: Prism' ArithException ()
-_Overflow = dimap seta (either id id) . right' . rmap (const Ex.Overflow)
- where seta Ex.Overflow = Right ()
- seta t = Left t
-
--- | Detect arithmetic underflow.
+-- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below right
+-- []
--
-_Underflow :: Prism' ArithException ()
-_Underflow = dimap seta (either id id) . right' . rmap (const Ex.Underflow)
- where seta Ex.Underflow = Right ()
- seta t = Left t
-
--- | Detect arithmetic loss of precision.
+-- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below right
+-- [["hail hydra!","foo","blah","woot"]]
--
-_LossOfPrecision :: Prism' ArithException ()
-_LossOfPrecision = dimap seta (either id id) . right' . rmap (const Ex.LossOfPrecision)
- where seta Ex.LossOfPrecision = Right ()
- seta t = Left t
+below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
+below k =
+ withPrism k $ \sta bt ->
+ flip prism (fmap bt) $ \s ->
+ case traverse sta s of
+ Left _ -> Left s
+ Right t -> Right t
+{-# INLINE below #-}
--- | Detect division by zero.
+-- | Use a 'Prism' to construct a 'PastroSum'.
--
-_DivideByZero :: Prism' ArithException ()
-_DivideByZero = dimap seta (either id id) . right' . rmap (const Ex.DivideByZero)
- where seta Ex.DivideByZero = Right ()
- seta t = Left t
+toPastroSum :: APrism s t a b -> p a b -> PastroSum p s t
+toPastroSum o p = withPrism o $ \sta bt -> PastroSum (join . B.first bt) p (eswap . sta)
--- | Detect exceptional denormalized floating pure.
+-- | Use a 'Prism' to construct a 'TambaraSum'.
--
-_Denormal :: Prism' ArithException ()
-_Denormal = dimap seta (either id id) . right' . rmap (const Ex.Denormal)
- where seta Ex.Denormal = Right ()
- seta t = Left t
+toTambaraSum :: Choice p => APrism s t a b -> p a b -> TambaraSum p s t
+toTambaraSum o p = withPrism o $ \sta bt -> TambaraSum (left . prism sta bt $ p)
--- | Detect zero denominators.
---
--- Added in @base@ 4.6 in response to this libraries discussion:
---
--- <http://haskell.1045720.n5.nabble.com/Data-Ratio-and-exceptions-td5711246.html>
---
-_RatioZeroDenominator :: Prism' ArithException ()
-_RatioZeroDenominator = dimap seta (either id id) . right' . rmap (const Ex.RatioZeroDenominator)
- where seta Ex.RatioZeroDenominator = Right ()
- seta t = Left t
+---------------------------------------------------------------------
+-- 'PrismRep' & 'CoprismRep'
+---------------------------------------------------------------------
-----------------------------------------------------------------------------------------------------
--- Array Exceptions
-----------------------------------------------------------------------------------------------------
+type APrism s t a b = Optic (PrismRep a b) s t a b
--- | Detect attempts to index an array outside its declared bounds.
---
-_IndexOutOfBounds :: Prism' ArrayException String
-_IndexOutOfBounds = dimap seta (either id id) . right' . rmap Ex.IndexOutOfBounds
- where seta (Ex.IndexOutOfBounds r) = Right r
- seta t = Left t
+type APrism' s a = APrism s s a a
--- | Detect attempts to evaluate an element of an array that has not been initialized.
+-- | The 'PrismRep' profunctor precisely characterizes a 'Prism'.
--
-_UndefinedElement :: Prism' ArrayException String
-_UndefinedElement = dimap seta (either id id) . right' . rmap Ex.UndefinedElement
- where seta (Ex.UndefinedElement r) = Right r
- seta t = Left t
-
-----------------------------------------------------------------------------------------------------
--- Miscellaneous Exceptions
-----------------------------------------------------------------------------------------------------
-
-trivial :: Profunctor p => t -> Optic' p t ()
-trivial t = const () `dimap` const t
+data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)
-_AssertionFailed :: Prism' Ex.AssertionFailed String
-_AssertionFailed = iso (\(Ex.AssertionFailed a) -> a) Ex.AssertionFailed
+instance Functor (PrismRep a b s) where
+ fmap f (PrismRep sta bt) = PrismRep (first f . sta) (f . bt)
+ {-# INLINE fmap #-}
--- | Thrown when the runtime system detects that the computation is guaranteed
--- not to terminate. Note that there is no guarantee that the runtime system
--- will notice whether any given computation is guaranteed to terminate or not.
---
-_NonTermination :: Prism' Ex.NonTermination ()
-_NonTermination = trivial Ex.NonTermination
+instance Profunctor (PrismRep a b) where
+ dimap f g (PrismRep sta bt) = PrismRep (first g . sta . f) (g . bt)
+ {-# INLINE dimap #-}
--- | Thrown when the program attempts to call atomically, from the
--- 'Control.Monad.STM' package, inside another call to atomically.
---
-_NestedAtomically :: Prism' Ex.NestedAtomically ()
-_NestedAtomically = trivial Ex.NestedAtomically
+ lmap f (PrismRep sta bt) = PrismRep (sta . f) bt
+ {-# INLINE lmap #-}
--- | The thread is blocked on an 'Control.Concurrent.MVar.MVar', but there
--- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't
--- ever continue.
---
-_BlockedIndefinitelyOnMVar :: Prism' Ex.BlockedIndefinitelyOnMVar ()
-_BlockedIndefinitelyOnMVar = trivial Ex.BlockedIndefinitelyOnMVar
+ rmap = fmap
+ {-# INLINE rmap #-}
--- | The thread is waiting to retry an 'Control.Monad.STM.STM' transaction,
--- but there are no other references to any TVars involved, so it can't ever
--- continue.
---
-_BlockedIndefinitelyOnSTM :: Prism' Ex.BlockedIndefinitelyOnSTM ()
-_BlockedIndefinitelyOnSTM = trivial Ex.BlockedIndefinitelyOnSTM
+instance Choice (PrismRep a b) where
+ left' (PrismRep sta bt) = PrismRep (either (first Left . sta) (Left . Right)) (Left . bt)
+ {-# INLINE left' #-}
--- | There are no runnable threads, so the program is deadlocked. The
--- 'Deadlock' 'Exception' is raised in the main thread only.
---
-_Deadlock :: Prism' Ex.Deadlock ()
-_Deadlock = trivial Ex.Deadlock
+ right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt)
+ {-# INLINE right' #-}
--- | A class method without a definition (neither a default definition,
--- nor a definition in the appropriate instance) was called.
---
-_NoMethodError :: Prism' Ex.NoMethodError String
-_NoMethodError = iso (\(Ex.NoMethodError a) -> a) Ex.NoMethodError
+type ACoprism s t a b = Optic (CoprismRep a b) s t a b
--- | A pattern match failed.
---
-_PatternMatchFail :: Prism' Ex.PatternMatchFail String
-_PatternMatchFail = iso (\(Ex.PatternMatchFail a) -> a) Ex.PatternMatchFail
+type ACoprism' s a = ACoprism s s a a
--- | An uninitialised record field was used.
---
-_RecConError :: Prism' Ex.RecConError String
-_RecConError = iso (\(Ex.RecConError a) -> a) Ex.RecConError
+data CoprismRep a b s t = CoprismRep (s -> a) (b -> a + t)
--- | A record selector was applied to a constructor without the appropriate
--- field. This can only happen with a datatype with multiple constructors,
--- where some fields are in one constructor but not another.
---
-_RecSelError :: Prism' Ex.RecSelError String
-_RecSelError = iso (\(Ex.RecSelError a) -> a) Ex.RecSelError
+instance Functor (CoprismRep a b s) where
+ fmap f (CoprismRep sa bat) = CoprismRep sa (second f . bat)
+ {-# INLINE fmap #-}
--- | A record update was performed on a constructor without the
--- appropriate field. This can only happen with a datatype with multiple
--- constructors, where some fields are in one constructor but not another.
---
-_RecUpdError :: Prism' Ex.RecUpdError String
-_RecUpdError = iso (\(Ex.RecUpdError a) -> a) Ex.RecUpdError
+instance Profunctor (CoprismRep a b) where
+ lmap f (CoprismRep sa bat) = CoprismRep (sa . f) bat
+ {-# INLINE lmap #-}
--- | Thrown when the user calls 'Prelude.error'.
---
-_ErrorCall :: Prism' Ex.ErrorCall String
-_ErrorCall = iso (\(Ex.ErrorCall a) -> a) Ex.ErrorCall
+ rmap = fmap
+ {-# INLINE rmap #-}
--- | This thread has exceeded its allocation limit.
---
-_AllocationLimitExceeded :: Prism' Ex.AllocationLimitExceeded ()
-_AllocationLimitExceeded = trivial AllocationLimitExceeded
+instance Cochoice (CoprismRep a b) where
+ unleft (CoprismRep sca batc) = CoprismRep (sca . Left) (forgetr $ either (eassocl . batc) Right)
+ {-# INLINE unleft #-}