diff --git a/optics-core/src/Optics/AffineFold.hs b/optics-core/src/Optics/AffineFold.hs index 8b47e087..446dfb72 100644 --- a/optics-core/src/Optics/AffineFold.hs +++ b/optics-core/src/Optics/AffineFold.hs @@ -46,7 +46,7 @@ module Optics.AffineFold -- there is not a unique choice of monoid to use that works for all optics, -- and the ('<>') operator could not be used to combine optics of different -- kinds. - , afailing + , afailing_ -- * Subtyping , An_AffineFold @@ -127,20 +127,20 @@ filtered p = afoldVL (\point f a -> if p a then f a else point a) -- | Try the first 'AffineFold'. If it returns no entry, try the second one. -- --- >>> preview (ix 1 % re _Left `afailing` ix 2 % re _Right) [0,1,2,3] +-- >>> preview (ix 1 % re _Left `afailing_` ix 2 % re _Right) [0,1,2,3] -- Just (Left 1) -- --- >>> preview (ix 42 % re _Left `afailing` ix 2 % re _Right) [0,1,2,3] +-- >>> preview (ix 42 % re _Left `afailing_` ix 2 % re _Right) [0,1,2,3] -- Just (Right 2) -- -afailing +afailing_ :: (Is k An_AffineFold, Is l An_AffineFold) => Optic' k is s a -> Optic' l js s a -> AffineFold s a -afailing a b = afolding $ \s -> maybe (preview b s) Just (preview a s) -infixl 3 `afailing` -- Same as (<|>) -{-# INLINE afailing #-} +afailing_ a b = afolding $ \s -> maybe (preview b s) Just (preview a s) +infixl 3 `afailing_` -- Same as (<|>) +{-# INLINE afailing_ #-} -- | Check to see if this 'AffineFold' doesn't match. -- diff --git a/optics-core/src/Optics/AffineTraversal.hs b/optics-core/src/Optics/AffineTraversal.hs index 1bad4cf2..85398fb0 100644 --- a/optics-core/src/Optics/AffineTraversal.hs +++ b/optics-core/src/Optics/AffineTraversal.hs @@ -48,6 +48,8 @@ module Optics.AffineTraversal -- * Additional elimination forms , withAffineTraversal + , afailing + -- * Subtyping , An_AffineTraversal -- | <> @@ -63,6 +65,7 @@ module Optics.AffineTraversal import Data.Profunctor.Indexed import Optics.Internal.Optic +import Optics.Internal.Utils -- | Type synonym for a type-modifying affine traversal. type AffineTraversal s t a b = Optic An_AffineTraversal NoIx s t a b @@ -165,6 +168,19 @@ matching :: Is k An_AffineTraversal => Optic k is s t a b -> s -> Either t a matching o = withAffineTraversal o $ \match _ -> match {-# INLINE matching #-} +afailing + :: (Is k An_AffineTraversal, Is l An_AffineTraversal) + => Optic k is s t a b + -> Optic l js s t a b + -> AffineTraversal s t a b +afailing a b = atraversalVL $ \point f s -> + let OrT visited fu = atraverseOf a (OrT False . point) (wrapOrT . f) s + in if visited + then fu + else atraverseOf b point f s +infixl 3 `afailing` -- Same as (<|>) +{-# INLINE afailing #-} + -- | Filter result(s) of a traversal that don't satisfy a predicate. -- -- /Note:/ This is /not/ a legal 'Optics.Traversal.Traversal', unless you are diff --git a/optics-core/src/Optics/Fold.hs b/optics-core/src/Optics/Fold.hs index 986dbf7f..34fe27f3 100644 --- a/optics-core/src/Optics/Fold.hs +++ b/optics-core/src/Optics/Fold.hs @@ -91,7 +91,7 @@ module Optics.Fold -- used to combine optics of different kinds. When porting code from @lens@ -- that uses '<>' to combine folds, use 'summing' instead. , summing - , failing + , failing_ -- * Subtyping , A_Fold @@ -279,23 +279,23 @@ infixr 6 `summing` -- Same as (<>) -- | Try the first 'Fold'. If it returns no entries, try the second one. -- --- >>> toListOf (ix 1 `failing` ix 0) [4,7] +-- >>> toListOf (ix 1 `failing_` ix 0) [4,7] -- [7] --- >>> toListOf (ix 1 `failing` ix 0) [4] +-- >>> toListOf (ix 1 `failing_` ix 0) [4] -- [4] -- -failing +failing_ :: (Is k A_Fold, Is l A_Fold) => Optic' k is s a -> Optic' l js s a -> Fold s a -failing a b = foldVL $ \f s -> +failing_ a b = foldVL $ \f s -> let OrT visited fu = traverseOf_ a (wrapOrT . f) s in if visited then fu else traverseOf_ b f s -infixl 3 `failing` -- Same as (<|>) -{-# INLINE failing #-} +infixl 3 `failing_` -- Same as (<|>) +{-# INLINE failing_ #-} ---------------------------------------- -- Special folds diff --git a/optics-core/src/Optics/IxAffineFold.hs b/optics-core/src/Optics/IxAffineFold.hs index ddd9de6a..8e650b8c 100644 --- a/optics-core/src/Optics/IxAffineFold.hs +++ b/optics-core/src/Optics/IxAffineFold.hs @@ -48,7 +48,7 @@ module Optics.IxAffineFold -- there is not a unique choice of monoid to use that works for all optics, -- and the ('<>') operator could not be used to combine optics of different -- kinds. - , iafailing + , iafailing_ -- * Subtyping , An_AffineFold @@ -129,13 +129,13 @@ filteredBy p = iafoldVL $ \point f s -> case preview p s of -- | Try the first 'IxAffineFold'. If it returns no entry, try the second one. -- -iafailing +iafailing_ :: (Is k An_AffineFold, Is l An_AffineFold, is1 `HasSingleIndex` i, is2 `HasSingleIndex` i) => Optic' k is1 s a -> Optic' l is2 s a -> IxAffineFold i s a -iafailing a b = conjoined (afailing a b) $ iafolding $ \s -> +iafailing_ a b = conjoined (afailing_ a b) $ iafolding $ \s -> maybe (ipreview b s) Just (ipreview a s) -infixl 3 `iafailing` -- Same as (<|>) -{-# INLINE iafailing #-} +infixl 3 `iafailing_` -- Same as (<|>) +{-# INLINE iafailing_ #-} diff --git a/optics-core/src/Optics/IxFold.hs b/optics-core/src/Optics/IxFold.hs index f5921fdb..db64ac3a 100644 --- a/optics-core/src/Optics/IxFold.hs +++ b/optics-core/src/Optics/IxFold.hs @@ -59,7 +59,7 @@ module Optics.IxFold -- not a unique choice of monoid to use, and the ('<>') operator could not be -- used to combine optics of different kinds. , isumming - , ifailing + , ifailing_ -- * Subtyping , A_Fold @@ -265,18 +265,18 @@ infixr 6 `isumming` -- Same as (<>) -- >>> itoListOf (_1 % ifolded `ifailing` _2 % ifolded) ([], ["b","c"]) -- [(0,"b"),(1,"c")] -- -ifailing +ifailing_ :: (Is k A_Fold, Is l A_Fold, is1 `HasSingleIndex` i, is2 `HasSingleIndex` i) => Optic' k is1 s a -> Optic' l is2 s a -> IxFold i s a -ifailing a b = conjoined (failing a b) $ ifoldVL $ \f s -> +ifailing_ a b = conjoined (failing_ a b) $ ifoldVL $ \f s -> let OrT visited fu = itraverseOf_ a (\i -> wrapOrT . f i) s in if visited then fu else itraverseOf_ b f s -infixl 3 `ifailing` -- Same as (<|>) -{-# INLINE ifailing #-} +infixl 3 `ifailing_` -- Same as (<|>) +{-# INLINE ifailing_ #-} ---------------------------------------- -- Special folds diff --git a/optics-core/src/Optics/IxTraversal.hs b/optics-core/src/Optics/IxTraversal.hs index 84943241..f5ef7e44 100644 --- a/optics-core/src/Optics/IxTraversal.hs +++ b/optics-core/src/Optics/IxTraversal.hs @@ -76,6 +76,7 @@ module Optics.IxTraversal -- and the ('<>') operator could not be used to combine optics of different -- kinds. , iadjoin + , ifailing -- * Subtyping , A_Traversal @@ -356,6 +357,20 @@ isingular o = conjoined (singular o) $ iatraversalVL $ \point f s -> Nothing -> pure a {-# INLINE isingular #-} +ifailing + :: ( Is k A_Traversal, Is l A_Traversal + , is1 `HasSingleIndex` i, is2 `HasSingleIndex` i) + => Optic k is1 s t a b + -> Optic l is2 s t a b + -> IxTraversal i s t a b +ifailing a b = conjoined (failing a b) $ itraversalVL $ \f s -> + let OrT visited fu = itraverseOf a (\i -> wrapOrT . f i) s + in if visited + then fu + else itraverseOf b f s +infixl 3 `ifailing` -- Same as (<|>) +{-# INLINE ifailing #-} + -- | Combine two disjoint indexed traversals into one. -- -- >>> iover (_1 % itraversed `iadjoin` _2 % itraversed) (+) ([0, 0, 0], (3, 5)) diff --git a/optics-core/src/Optics/Traversal.hs b/optics-core/src/Optics/Traversal.hs index ed30a26e..befa66f0 100644 --- a/optics-core/src/Optics/Traversal.hs +++ b/optics-core/src/Optics/Traversal.hs @@ -83,6 +83,7 @@ module Optics.Traversal -- is not a unique choice of monoid to use that works for all optics, and the -- ('<>') operator could not be used to combine optics of different kinds. , adjoin + , failing -- * Subtyping , A_Traversal @@ -385,6 +386,20 @@ singular o = atraversalVL $ \point f s -> Nothing -> pure a {-# INLINE singular #-} +failing + :: (Is k A_Traversal, Is l A_Traversal) + => Optic k is s t a b + -> Optic l js s t a b + -> Traversal s t a b +failing a b = traversalVL $ \f s -> + let OrT visited fu = traverseOf a (wrapOrT . f) s + in if visited + then fu + else traverseOf b f s +infixl 3 `failing` -- Same as (<|>) +{-# INLINE failing #-} + + -- | Combine two disjoint traversals into one. -- -- >>> over (_1 % _Just `adjoin` _2 % _Right) not (Just True, Right False) diff --git a/optics-th/src/Optics/TH/Internal/Product.hs b/optics-th/src/Optics/TH/Internal/Product.hs index 8dabfe70..62a53f1b 100644 --- a/optics-th/src/Optics/TH/Internal/Product.hs +++ b/optics-th/src/Optics/TH/Internal/Product.hs @@ -935,4 +935,4 @@ addFieldClassName n = modify $ S.insert n -- We want to catch type families, but not *data* families. See #799. typeFamilyHead :: AffineFold Dec TypeFamilyHead -typeFamilyHead = _OpenTypeFamilyD `afailing` _ClosedTypeFamilyD % _1 +typeFamilyHead = _OpenTypeFamilyD `afailing_` _ClosedTypeFamilyD % _1