diff --git a/optics-core/CHANGELOG.md b/optics-core/CHANGELOG.md index 0b333fc1..fe80b970 100644 --- a/optics-core/CHANGELOG.md +++ b/optics-core/CHANGELOG.md @@ -1,3 +1,9 @@ +# optics-core-0.5 (???) +* Restrict `over'`, `iover'`, `set'`, and associated operators to require + traversals rather than just setters. Setters are not capable of actually + making strict modifications, so these operations were just silently lazier + than expected when passed setters. + # optics-core-0.4.1 (2022-03-22) * Add support for GHC-9.2 * Add `is` ([#410](https://github.com/well-typed/optics/pull/410)) diff --git a/optics-core/optics-core.cabal b/optics-core/optics-core.cabal index 839ae78a..94599048 100644 --- a/optics-core/optics-core.cabal +++ b/optics-core/optics-core.cabal @@ -77,6 +77,7 @@ library , indexed-profunctors >= 0.1 && <0.2 , transformers >= 0.5 && <0.7 , indexed-traversable >= 0.1 && <0.2 + , OneTuple >= 0.3 && <0.4 exposed-modules: Optics.Core diff --git a/optics-core/src/Optics/Internal/Utils.hs b/optics-core/src/Optics/Internal/Utils.hs index abcf930b..e3470f2b 100644 --- a/optics-core/src/Optics/Internal/Utils.hs +++ b/optics-core/src/Optics/Internal/Utils.hs @@ -3,11 +3,7 @@ -- | This module is intended for internal use only, and may change without warning -- in subsequent releases. module Optics.Internal.Utils - ( Identity'(..) - , wrapIdentity' - , unwrapIdentity' - - , Traversed(..) + ( Traversed(..) , runTraversed , OrT(..) @@ -22,42 +18,6 @@ import qualified Data.Semigroup as SG import Data.Profunctor.Indexed --- Needed for strict application of (indexed) setters. --- --- Credit for this goes to Eric Mertens, see --- . -data Identity' a = Identity' {-# UNPACK #-} !() a - deriving Functor - -instance Applicative Identity' where - pure a = Identity' () a - Identity' () f <*> Identity' () x = Identity' () (f x) - -instance Mapping (Star Identity') where - roam f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k) - iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k) - -instance Mapping (IxStar Identity') where - roam f (IxStar k) = - IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i) - iroam f (IxStar k) = - IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i)) - --- | Mark a value for evaluation to whnf. --- --- This allows us to, when applying a setter to a structure, evaluate only the --- parts that we modify. If an optic focuses on multiple targets, Applicative --- instance of Identity' makes sure that we force evaluation of all of them, but --- we leave anything else alone. --- -wrapIdentity' :: a -> Identity' a -wrapIdentity' a = Identity' (a `seq` ()) a - -unwrapIdentity' :: Identity' a -> a -unwrapIdentity' (Identity' () a) = a - ----------------------------------------- - -- | Helper for 'Optics.Fold.traverseOf_' and the like for better -- efficiency than the foldr-based version. -- diff --git a/optics-core/src/Optics/IxSetter.hs b/optics-core/src/Optics/IxSetter.hs index ad7899b6..058a055d 100644 --- a/optics-core/src/Optics/IxSetter.hs +++ b/optics-core/src/Optics/IxSetter.hs @@ -58,6 +58,7 @@ module Optics.IxSetter ) where import Data.Profunctor.Indexed +import Data.Tuple.Solo (Solo (..), getSolo) import Optics.Internal.Indexed import Optics.Internal.Indexed.Classes @@ -81,12 +82,12 @@ iover o = \f -> runIxFunArrow (getOptic (castOptic @A_Setter o) (IxFunArrow f)) -- | Apply an indexed setter as a modifier, strictly. iover' - :: (Is k A_Setter, is `HasSingleIndex` i) + :: (Is k A_Traversal, is `HasSingleIndex` i) => Optic k is s t a b -> (i -> a -> b) -> s -> t iover' o = \f -> - let star = getOptic (castOptic @A_Setter o) $ IxStar (\i -> wrapIdentity' . f i) - in unwrapIdentity' . runIxStar star id + let star = getOptic (castOptic @A_Traversal o) $ IxStar (\i -> (Solo $!) . f i) + in getSolo . runIxStar star id {-# INLINE iover' #-} @@ -105,7 +106,7 @@ iset o = \f -> iover o (\i _ -> f i) -- | Apply an indexed setter, strictly. iset' - :: (Is k A_Setter, is `HasSingleIndex` i) + :: (Is k A_Traversal, is `HasSingleIndex` i) => Optic k is s t a b -> (i -> b) -> s -> t iset' o = \f -> iover' o (\i _ -> f i) diff --git a/optics-core/src/Optics/IxTraversal.hs b/optics-core/src/Optics/IxTraversal.hs index 84943241..37a58ba5 100644 --- a/optics-core/src/Optics/IxTraversal.hs +++ b/optics-core/src/Optics/IxTraversal.hs @@ -97,6 +97,7 @@ import Control.Monad.Trans.State import Data.Functor.Identity import Data.Profunctor.Indexed +import Data.Tuple.Solo (Solo (..)) import Optics.Internal.Indexed import Optics.Internal.Indexed.Classes @@ -227,9 +228,9 @@ ifailover' => Optic k is s t a b -> (i -> a -> b) -> s -> Maybe t ifailover' o = \f s -> - let OrT visited t = itraverseOf o (\i -> wrapOrT . wrapIdentity' . f i) s + let OrT visited t = itraverseOf o (\i -> wrapOrT . (Solo $!) . f i) s in if visited - then Just (unwrapIdentity' t) + then case t of Solo v -> Just v else Nothing {-# INLINE ifailover' #-} diff --git a/optics-core/src/Optics/Operators.hs b/optics-core/src/Optics/Operators.hs index e110dbaf..596e1349 100644 --- a/optics-core/src/Optics/Operators.hs +++ b/optics-core/src/Optics/Operators.hs @@ -28,6 +28,7 @@ import Optics.Getter import Optics.Optic import Optics.Review import Optics.Setter +import Optics.Traversal -- | Flipped infix version of 'view'. (^.) :: Is k A_Getter => s -> Optic' k is s a -> a @@ -65,7 +66,7 @@ infixr 8 # infixr 4 %~ -- | Infix version of 'over''. -(%!~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t +(%!~) :: Is k A_Traversal => Optic k is s t a b -> (a -> b) -> s -> t (%!~) = over' {-# INLINE (%!~) #-} @@ -79,7 +80,7 @@ infixr 4 %!~ infixr 4 .~ -- | Infix version of 'set''. -(!~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t +(!~) :: Is k A_Traversal => Optic k is s t a b -> b -> s -> t (!~) = set' {-# INLINE (!~) #-} @@ -103,7 +104,7 @@ infixr 4 !~ infixr 4 ?~ -- | Strict version of ('?~'). -(?!~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t +(?!~) :: Is k A_Traversal => Optic k is s t a (Maybe b) -> b -> s -> t (?!~) = \o !b -> set' o (Just b) {-# INLINE (?!~) #-} diff --git a/optics-core/src/Optics/Setter.hs b/optics-core/src/Optics/Setter.hs index 5a391838..acff7c76 100644 --- a/optics-core/src/Optics/Setter.hs +++ b/optics-core/src/Optics/Setter.hs @@ -63,10 +63,10 @@ module Optics.Setter ) where import Data.Profunctor.Indexed +import Data.Tuple.Solo (Solo (..), getSolo) import Optics.Internal.Optic import Optics.Internal.Setter -import Optics.Internal.Utils -- | Type synonym for a type-modifying setter. type Setter s t a b = Optic A_Setter NoIx s t a b @@ -102,14 +102,28 @@ over o = \f -> runFunArrow $ getOptic (castOptic @A_Setter o) (FunArrow f) -- 'over' is used, because the first coordinate of a pair is never forced. -- over' - :: Is k A_Setter + :: Is k A_Traversal => Optic k is s t a b -> (a -> b) -> s -> t +-- See [Note: Solo wrapping] over' o = \f -> - let star = getOptic (castOptic @A_Setter o) $ Star (wrapIdentity' . f) - in unwrapIdentity' . runStar star + let star = getOptic (castOptic @A_Traversal o) $ Star ((Solo $!) . f) + in getSolo . runStar star {-# INLINE over' #-} +-- Note: Solo wrapping +-- +-- We use Solo for strict application of (indexed) setters. +-- +-- Credit for this idea goes to Eric Mertens; see +-- . +-- +-- Using Solo rather than Identity allows us, when applying a traversal to a +-- structure, to evaluate only the parts that we modify. If an optic focuses on +-- multiple targets, the Applicative instance of Solo (combined with applying +-- the Solo data constructor strictly) makes sure that we force evaluation of +-- all of them, but we leave anything else alone. + -- | Apply a setter. -- -- @ @@ -128,10 +142,11 @@ set o = over o . const -- | Apply a setter, strictly. -- --- TODO DOC: what exactly is the strictness property? --- +-- The new value will be forced if and only if the optic traverses at +-- least one target. If forcing the new value is inexpensive, then it +-- is cheaper to do so manually and use 'set'. set' - :: Is k A_Setter + :: Is k A_Traversal => Optic k is s t a b -> b -> s -> t set' o = over' o . const diff --git a/optics-core/src/Optics/Traversal.hs b/optics-core/src/Optics/Traversal.hs index fc15d1ea..dab497b1 100644 --- a/optics-core/src/Optics/Traversal.hs +++ b/optics-core/src/Optics/Traversal.hs @@ -105,6 +105,8 @@ import Data.Bitraversable import Data.Functor.Identity import Data.Profunctor.Indexed +import Data.Tuple.Solo (Solo (..)) + import Optics.AffineTraversal import Optics.Fold import Optics.Internal.Optic @@ -305,9 +307,9 @@ failover' => Optic k is s t a b -> (a -> b) -> s -> Maybe t failover' o = \f s -> - let OrT visited t = traverseOf o (wrapOrT . wrapIdentity' . f) s + let OrT visited t = traverseOf o (wrapOrT . (Solo $!) . f) s in if visited - then Just (unwrapIdentity' t) + then case t of Solo v -> Just v else Nothing {-# INLINE failover' #-} diff --git a/optics-extra/CHANGELOG.md b/optics-extra/CHANGELOG.md index a1fed79d..ccc421d0 100644 --- a/optics-extra/CHANGELOG.md +++ b/optics-extra/CHANGELOG.md @@ -1,3 +1,8 @@ +# optics-extra-0.5 (????) +* Restrict `modifying'` and `assign'` to traversals. Setters are not capable of + actually making strict modifications, so these operations were just silently + lazier than expected when passed setters. + # optics-extra-0.4.2.1 (2022-05-20) * Fix for previous release when used with `mtl-2.3` and `transformers-0.5`. diff --git a/optics-extra/src/Optics/State.hs b/optics-extra/src/Optics/State.hs index 9d683e67..f0b5fbf3 100644 --- a/optics-extra/src/Optics/State.hs +++ b/optics-extra/src/Optics/State.hs @@ -43,7 +43,7 @@ modifying o = modify . over o -- >>> flip evalState ('a','b') $ modifying' _1 (errorWithoutStackTrace "oops") -- *** Exception: oops modifying' - :: (Is k A_Setter, MonadState s m) + :: (Is k A_Traversal, MonadState s m) => Optic k is s s a b -> (a -> b) -> m () @@ -75,7 +75,7 @@ assign o = modifying o . const -- >>> flip evalState ('a','b') $ assign' _1 (errorWithoutStackTrace "oops") -- *** Exception: oops assign' - :: (Is k A_Setter, MonadState s m) + :: (Is k A_Traversal, MonadState s m) => Optic k is s s a b -> b -> m () diff --git a/optics/tests/Optics/Tests/Eta.hs b/optics/tests/Optics/Tests/Eta.hs index 664e4748..da05555d 100644 --- a/optics/tests/Optics/Tests/Eta.hs +++ b/optics/tests/Optics/Tests/Eta.hs @@ -96,9 +96,9 @@ eta7lhs = over mapped eta7rhs f = over mapped f eta8lhs, eta8rhs - :: Functor f => (a -> b) -> f a -> f b -eta8lhs = over' mapped -eta8rhs f = over' mapped f + :: Traversable f => (a -> b) -> f a -> f b +eta8lhs = over' traversed +eta8rhs f = over' traversed f eta9lhs, eta9rhs :: FunctorWithIndex i f => (i -> a -> b) -> f a -> f b @@ -106,9 +106,9 @@ eta9lhs = iover imapped eta9rhs f = iover imapped f eta10lhs, eta10rhs - :: FunctorWithIndex i f => (i -> a -> b) -> f a -> f b -eta10lhs = iover' imapped -eta10rhs f = iover' imapped f + :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b +eta10lhs = iover' itraversed +eta10rhs f = iover' itraversed f eta11lhs, eta11rhs :: (FunctorWithIndex i f, FunctorWithIndex j g) @@ -117,7 +117,7 @@ eta11lhs = iset (imapped <%> imapped) eta11rhs f = iset (imapped <%> imapped) f eta12lhs, eta12rhs - :: (FunctorWithIndex i f, FunctorWithIndex j g) + :: (TraversableWithIndex i f, TraversableWithIndex j g) => ((i, j) -> b) -> f (g a) -> f (g b) -eta12lhs = iset' (imapped <%> imapped) -eta12rhs f = iset' (imapped <%> imapped) f +eta12lhs = iset' (itraversed <%> itraversed) +eta12rhs f = iset' (itraversed <%> itraversed) f