From 26bdaac49279c35a940817d6c1ad091b742537a7 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sun, 12 May 2024 11:31:29 -0400 Subject: [PATCH] Define variants of #1058 operators which return old result As requested in https://github.com/ekmett/lens/pull/1068#pullrequestreview-2051269100. --- CHANGELOG.markdown | 12 ++++++++-- src/Control/Lens/Combinators.hs | 6 +++++ src/Control/Lens/Cons.hs | 40 +++++++++++++++++++++++++++++---- src/Control/Lens/Lens.hs | 26 +++++++++++++++++---- src/Control/Lens/Operators.hs | 6 +++++ tests/hunit.hs | 28 +++++++++++++++++++++-- 6 files changed, 106 insertions(+), 12 deletions(-) diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown index 70e31d75f..ebc79e381 100644 --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,8 +1,16 @@ next [????.??.??] ----------------- +* Define the following lenses that perform an operation and result the old + result: + * `(<<<>:~)` (prepend to the front via `(<>)` and return the old result) + * `(<<<|~)` (prepend to the front via `(<|)` and return the old result) + * `(<<|>~)` (append to the back via `(|>)` and return the old result) + + Each of these also has a variant that end with `=` instead of `~` (e.g., + `(<<<>:=)`) for working in a `MonadState` setting. * Re-export `(<>:~)`, `(<<>:~)`, `(<|~)`, `(<<|~)`, `(|>~)`, and `(<|>~)` (as - well as their variants which end with `=` instead of `~`) from - `Control.Lens.Operators`. + well as their variants which end with `=` instead of `~`, and their variants + which return the old result) from `Control.Lens.Operators`. 5.3.1 [2024.05.05] ------------------ diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs index 2dbfb9509..6a0551937 100644 --- a/src/Control/Lens/Combinators.hs +++ b/src/Control/Lens/Combinators.hs @@ -141,10 +141,16 @@ import Control.Lens hiding , (<>=) , (<>:~) , (<>:=) + , (<<>:~) + , (<<>:=) , (<|~) , (<|=) + , (<<|~) + , (<<|=) , (|>~) , (|>=) + , (<|>~) + , (<|>=) , (%@~) , (%@=) , (:>) diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs index 286300059..a8ec33e90 100644 --- a/src/Control/Lens/Cons.hs +++ b/src/Control/Lens/Cons.hs @@ -27,7 +27,7 @@ module Control.Lens.Cons , cons , uncons , _head, _tail - , (<|~), (<|=), (<<|~), (<<|=) + , (<|~), (<|=), (<<|~), (<<|=), (<<<|~), (<<<|=) , pattern (:<) -- * Snoc , Snoc(..) @@ -35,7 +35,7 @@ module Control.Lens.Cons , snoc , unsnoc , _init, _last - , (|>~), (|>=), (<|>~), (<|>=) + , (|>~), (|>=), (<|>~), (<|>=), (<<|>~), (<<|>=) , pattern (:>) ) where @@ -82,8 +82,8 @@ import Prelude infixr 5 <|, `cons` infixl 5 |>, `snoc` -infixr 4 <|~, |>~, <<|~, <|>~ -infix 4 <|=, |>=, <<|=, <|>= +infixr 4 <|~, |>~, <<|~, <|>~, <<<|~, <<|>~ +infix 4 <|=, |>=, <<|=, <|>=, <<<|=, <<|>= pattern (:<) :: Cons b b a a => a -> b -> b pattern (:<) a s <- (preview _Cons -> Just (a,s)) where @@ -351,6 +351,14 @@ l <|= a = State.modify (l <|~ a) l <<|~ m = l <%~ (m <|) {-# INLINE (<<|~) #-} +-- | ('<|') a 'Cons' value onto the end of the target of a 'Lens' and +-- return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible. +(<<<|~) :: Cons b b a a => LensLike' ((,) b) s b -> a -> s -> (b, s) +l <<<|~ m = l <<%~ (m <|) +{-# INLINE (<<<|~) #-} + -- | ('<|') a 'Semigroup' value onto the end of the target of a 'Lens' into -- your 'Monad''s state and return the result. -- @@ -359,6 +367,14 @@ l <<|~ m = l <%~ (m <|) l <<|= r = l <%= (r <|) {-# INLINE (<<|=) #-} +-- | ('<|') a 'Semigroup' value onto the end of the target of a 'Lens' into +-- your 'Monad''s state and return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible. +(<<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b +l <<<|= r = l <<%= (r <|) +{-# INLINE (<<<|=) #-} + ------------------------------------------------------------------------------ -- Snoc ------------------------------------------------------------------------------ @@ -596,6 +612,14 @@ l |>= a = State.modify (l |>~ a) l <|>~ m = l <%~ (|> m) {-# INLINE (<|>~) #-} +-- | ('|>') a 'Cons' value onto the end of the target of a 'Lens' and +-- return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible. +(<<|>~) :: Snoc b b p p => LensLike' ((,) b) s b -> p -> s -> (b, s) +l <<|>~ m = l <<%~ (|> m) +{-# INLINE (<<|>~) #-} + -- | ('|>') a 'Semigroup' value onto the end of the target of a 'Lens' into -- your 'Monad''s state and return the result. -- @@ -603,3 +627,11 @@ l <|>~ m = l <%~ (|> m) (<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b l <|>= r = l <%= (|> r) {-# INLINE (<|>=) #-} + +-- | ('|>') a 'Semigroup' value onto the end of the target of a 'Lens' into +-- your 'Monad''s state and return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible. +(<<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b +l <<|>= r = l <<%= (|> r) +{-# INLINE (<<|>=) #-} diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs index 3f06b9f5b..c34f3ecb2 100644 --- a/src/Control/Lens/Lens.hs +++ b/src/Control/Lens/Lens.hs @@ -90,7 +90,7 @@ module Control.Lens.Lens , (<||~), (<&&~), (<<>~), (<<>:~) , (<<%~), (<<.~), (<~) + , (<<||~), (<<&&~), (<<<>~), (<<<>:~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=), (<<>:=) , (<<%=), (<<.=), (<=) + , (<<||=), (<<&&=), (<<<>=), (<<<>:=) , (<<~) -- * Cloning Lenses @@ -164,9 +164,9 @@ import GHC.Exts (TYPE) infixl 8 ^# infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <<>:~, <%~, <<%~, <<.~, <~ + , <<+~, <<-~, <<*~, <~, <<<>:~ infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <<>:=, <%=, <<%=, <<.=, <= + , <<+=, <<-=, <<*=, <=, <<<>:= infixr 2 <<~ infixl 1 ??, &~ @@ -1201,6 +1201,15 @@ l <<>= r = l <%= (<> r) l <<>:~ m = l <%~ (m <>) {-# INLINE (<<>:~) #-} +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and +-- return the /old/ result. +-- However, unlike ('<<>~'), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible. +(<<<>:~) :: Semigroup m => LensLike' ((,)m) s m -> m -> s -> (m, s) +l <<<>:~ m = l <<%~ (m <>) +{-# INLINE (<<<>:~) #-} + -- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into -- your 'Monad''s state and return the result. -- However, unlike ('<<>='), it is prepended to the head side. @@ -1210,6 +1219,15 @@ l <<>:~ m = l <%~ (m <>) l <<>:= r = l <%= (r <>) {-# INLINE (<<>:=) #-} +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into +-- your 'Monad''s state and return the /old/ result. +-- However, unlike ('<<<>='), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible. +(<<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,)r) s r -> r -> m r +l <<<>:= r = l <<%= (r <>) +{-# INLINE (<<<>:=) #-} + ------------------------------------------------------------------------------ -- Arrow operators ------------------------------------------------------------------------------ diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs index 8fc27b5bf..792aa1376 100644 --- a/src/Control/Lens/Operators.hs +++ b/src/Control/Lens/Operators.hs @@ -22,10 +22,14 @@ module Control.Lens.Operators , (<|=) , (<<|~) , (<<|=) + , (<<<|~) + , (<<<|=) , (|>~) , (|>=) , (<|>~) , (<|>=) + , (<<|>~) + , (<<|>=) -- * "Control.Lens.Fold" , (^..) , (^?) @@ -70,6 +74,7 @@ module Control.Lens.Operators , (<<||~) , (<<&&~) , (<<<>~) + , (<<<>:~) , (<%=) , (<+=) , (<-=) @@ -93,6 +98,7 @@ module Control.Lens.Operators , (<<||=) , (<<&&=) , (<<<>=) + , (<<<>:=) , (<<~) , (<<>~) , (<<>=) diff --git a/tests/hunit.hs b/tests/hunit.hs index 73e7880c6..25ec00971 100644 --- a/tests/hunit.hs +++ b/tests/hunit.hs @@ -292,15 +292,35 @@ case_snoc_to_state_record_field_and_access_new_value = trig' = trig { _points = (trig & _points) `snoc` origin } case_append_to_record_field_and_access_old_value = - (trig & points <<%~ (<>[origin])) + (trig & points <<<>~ [ origin ]) @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] }) case_append_to_state_record_field_and_access_old_value = do runState test trig @?= (_points trig, trig') where - test = points <<%= (<>[origin]) + test = points <<<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_cons_to_record_field_and_access_old_value = + (trig & points <<<|~ origin) + @?= (_points trig, trig { _points = origin : (trig & _points) }) + +case_cons_to_state_record_field_and_access_old_value = + runState test trig @?= (_points trig, trig') + where + test = points <<<|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_snoc_to_record_field_and_access_old_value = + (trig & points <<|>~ origin) + @?= (_points trig, trig { _points = (trig & _points) `snoc` origin }) + +case_snoc_to_state_record_field_and_access_old_value = + runState test trig @?= (_points trig, trig') + where + test = points <<|>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin" case_read_maybe_state_map_entry = @@ -399,6 +419,10 @@ main = defaultMain , testCase "snoc to state record field and access new value" case_snoc_to_state_record_field_and_access_new_value , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value + , testCase "cons to record field and access old value" case_cons_to_record_field_and_access_old_value + , testCase "cons to state record field and access old value" case_cons_to_state_record_field_and_access_old_value + , testCase "snoc to record field and access old value" case_snoc_to_record_field_and_access_old_value + , testCase "snoc to state record field and access old value" case_snoc_to_state_record_field_and_access_old_value , testCase "read maybe map entry" case_read_maybe_map_entry , testCase "read maybe state map entry" case_read_maybe_state_map_entry , testCase "read map entry" case_read_map_entry