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 well-typed#473
  • Loading branch information
treeowl committed Dec 28, 2022
1 parent cf35bef commit 9ef85c8
Show file tree
Hide file tree
Showing 4 changed files with 13 additions and 21 deletions.
10 changes: 0 additions & 10 deletions optics-core/src/Optics/Internal/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -28,16 +28,6 @@ import Data.Tuple.Solo (Solo (..), getSolo)
-- 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
Expand Down
6 changes: 3 additions & 3 deletions optics-core/src/Optics/IxSetter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -81,11 +81,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 -> wrapSolo' . f i)
in getSolo . runIxStar star id

{-# INLINE iover' #-}
Expand All @@ -105,7 +105,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
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
11 changes: 6 additions & 5 deletions optics-core/src/Optics/Setter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -102,11 +102,11 @@ 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
over' o = \f ->
let star = getOptic (castOptic @A_Setter o) $ Star (wrapSolo' . f)
let star = getOptic (castOptic @A_Traversal o) $ Star (wrapSolo' . f)
in getSolo . runStar star
{-# INLINE over' #-}

Expand All @@ -128,10 +128,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

0 comments on commit 9ef85c8

Please sign in to comment.