Skip to content

Commit

Permalink
Restrict over', iover', and set' to traversals
Browse files Browse the repository at this point in the history
* `over'`, `iover'`, `set'`, and associated operators previously
  accepted setters. However, it's impossible to actually modify strictly
  through a setter; a traversal is needed for that. Restrict the types
  to require `A_Traversal`, and remove the associated (technically
  correct but deceptive) `Mapping` instances.

* Document the strictness behavior of `set'`.

Fixes #473
  • Loading branch information
treeowl committed Dec 28, 2022
1 parent a3b2d99 commit 40a38d2
Show file tree
Hide file tree
Showing 10 changed files with 57 additions and 58 deletions.
6 changes: 6 additions & 0 deletions optics-core/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -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))
Expand Down
34 changes: 1 addition & 33 deletions optics-core/src/Optics/Internal/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,11 +3,7 @@
-- | This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Optics.Internal.Utils
( Solo (..)
, wrapSolo'
, getSolo

, Traversed(..)
( Traversed(..)
, runTraversed

, OrT(..)
Expand All @@ -21,34 +17,6 @@ module Optics.Internal.Utils
import qualified Data.Semigroup as SG

import Data.Profunctor.Indexed
import Data.Tuple.Solo (Solo (..), getSolo)

-- Needed for strict application of (indexed) setters.
--
-- Credit for this goes to Eric Mertens, see
-- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.

instance Mapping (Star Solo) where
roam f (Star k) = Star $ wrapSolo' . f (getSolo . k)
iroam f (Star k) = Star $ wrapSolo' . f (\_ -> getSolo . k)

instance Mapping (IxStar Solo) where
roam f (IxStar k) =
IxStar $ \i -> wrapSolo' . f (getSolo . k i)
iroam f (IxStar k) =
IxStar $ \ij -> wrapSolo' . f (\i -> getSolo . 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.
--
wrapSolo' :: a -> Solo a
wrapSolo' a = Solo $! a

----------------------------------------

-- | Helper for 'Optics.Fold.traverseOf_' and the like for better
-- efficiency than the foldr-based version.
Expand Down
7 changes: 4 additions & 3 deletions optics-core/src/Optics/IxSetter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -81,11 +82,11 @@ 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 -> wrapSolo' . f i)
let star = getOptic (castOptic @A_Traversal o) $ IxStar (\i -> (Solo $!) . f i)
in getSolo . runIxStar star id

{-# INLINE iover' #-}
Expand All @@ -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)
Expand Down
3 changes: 2 additions & 1 deletion optics-core/src/Optics/IxTraversal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -227,7 +228,7 @@ 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 . wrapSolo' . f i) s
let OrT visited t = itraverseOf o (\i -> wrapOrT . (Solo $!) . f i) s
in if visited
then case t of Solo v -> Just v
else Nothing
Expand Down
7 changes: 4 additions & 3 deletions optics-core/src/Optics/Operators.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 (%!~) #-}

Expand All @@ -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 (!~) #-}

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

Expand Down
27 changes: 21 additions & 6 deletions optics-core/src/Optics/Setter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 (wrapSolo' . f)
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.
--
-- @
Expand All @@ -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
Expand Down
4 changes: 3 additions & 1 deletion optics-core/src/Optics/Traversal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -305,7 +307,7 @@ failover'
=> Optic k is s t a b
-> (a -> b) -> s -> Maybe t
failover' o = \f s ->
let OrT visited t = traverseOf o (wrapOrT . wrapSolo' . f) s
let OrT visited t = traverseOf o (wrapOrT . (Solo $!) . f) s
in if visited
then case t of Solo v -> Just v
else Nothing
Expand Down
5 changes: 5 additions & 0 deletions optics-extra/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -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`.

Expand Down
4 changes: 2 additions & 2 deletions optics-extra/src/Optics/State.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand Down Expand Up @@ -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 ()
Expand Down
18 changes: 9 additions & 9 deletions optics/tests/Optics/Tests/Eta.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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

0 comments on commit 40a38d2

Please sign in to comment.