Restrict over', iover', and set' to traversals

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))

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
 

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
--- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.
-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.
 --

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)

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' #-}
 

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 (?!~) #-}
 

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
+-- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.
+--
+-- 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

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' #-}
 

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`.
 

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 ()

optics/tests/Optics/Tests/Eta.hs

@@ -96,19 +96,19 @@ 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
 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