diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs index 4174ee661..07d7ac3cd 100644 --- a/src/Control/Lens/Combinators.hs +++ b/src/Control/Lens/Combinators.hs @@ -139,6 +139,12 @@ import Control.Lens hiding , (~) , (<>=) + , (<>:~) + , (<>:=) + , (<|~) + , (<|~) + , (|>~) + , (|>=) , (%@~) , (%@=) , (:>) diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs index bda33c190..286300059 100644 --- a/src/Control/Lens/Cons.hs +++ b/src/Control/Lens/Cons.hs @@ -27,6 +27,7 @@ module Control.Lens.Cons , cons , uncons , _head, _tail + , (<|~), (<|=), (<<|~), (<<|=) , pattern (:<) -- * Snoc , Snoc(..) @@ -34,14 +35,17 @@ module Control.Lens.Cons , snoc , unsnoc , _init, _last + , (|>~), (|>=), (<|>~), (<|>=) , pattern (:>) ) where import Control.Lens.Equality (simply) import Control.Lens.Fold +import Control.Lens.Lens import Control.Lens.Prism import Control.Lens.Review +import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Type import qualified Data.ByteString as StrictB @@ -62,6 +66,7 @@ import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox import Data.Word import Control.Applicative (ZipList(..)) +import Control.Monad.State.Class as State import Prelude -- $setup @@ -77,6 +82,8 @@ import Prelude infixr 5 <|, `cons` infixl 5 |>, `snoc` +infixr 4 <|~, |>~, <<|~, <|>~ +infix 4 <|=, |>=, <<|=, <|>= pattern (:<) :: Cons b b a a => a -> b -> b pattern (:<) a s <- (preview _Cons -> Just (a,s)) where @@ -323,6 +330,35 @@ _tail :: Cons s s a a => Traversal' s s _tail = _Cons._2 {-# INLINE _tail #-} +-- | Modify the target of a 'Cons' value by using @('<|')@. +-- +-- >>> (["world"], ["lens"]) & _1 <|~ "hello" +-- (["hello","world"],["lens"]) +(<|~) :: Cons b b a a => ASetter s t b b -> a -> s -> t +l <|~ n = over l (n <|) +{-# INLINE (<|~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('<|')@. +(<|=) :: (MonadState s m, Cons b b a a) => ASetter s s b b -> a -> m () +l <|= a = State.modify (l <|~ a) +{-# INLINE (<|=) #-} + +-- | ('<|') a 'Cons' value onto the end of the target of a 'Lens' and +-- return the 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 t b b -> a -> s -> (b, t) +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. +-- +-- 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 ------------------------------------------------------------------------------ @@ -538,3 +574,32 @@ snoc = curry (simply review _Snoc) unsnoc :: Snoc s s a a => s -> Maybe (s, a) unsnoc = simply preview _Snoc {-# INLINE unsnoc #-} + +-- | Modify the target of a 'Cons' value by using @('|>')@. +-- +-- >>> (["world"], ["lens"]) & _1 |>~ "hello" +-- (["world","hello"],["lens"]) +(|>~) :: Snoc b b a a => ASetter s t b b -> a -> s -> t +l |>~ n = over l (|> n) +{-# INLINE (|>~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('|>')@. +(|>=) :: (MonadState s m, Snoc b b a a) => ASetter s s b b -> a -> m () +l |>= a = State.modify (l |>~ a) +{-# INLINE (|>=) #-} + +-- | ('|>') a 'Cons' value onto the end of the target of a 'Lens' and +-- return the 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 t b b -> p -> s -> (b, t) +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. +-- +-- 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 1a17be7f3..5e7ba202a 100644 --- a/src/Control/Lens/Lens.hs +++ b/src/Control/Lens/Lens.hs @@ -87,7 +87,7 @@ module Control.Lens.Lens -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (~) + , (<||~), (<&&~), (<<>~), (<<>:~) , (<<%~), (<<.~), (<~) @@ -95,7 +95,7 @@ module Control.Lens.Lens -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=) + , (<||=), (<&&=), (<<>=), (<<>:=) , (<<%=), (<<.=), (<=) @@ -163,9 +163,9 @@ import GHC.Exts (TYPE) -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^# -infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <%~, <<%~, <<.~, <~, <<>:~, <%~, <<%~, <<.~, <~ -infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <%=, <<%=, <<.=, <=, <<>:=, <%=, <<%=, <<.=, <= infixr 2 <<~ infixl 1 ??, &~ @@ -1192,6 +1192,24 @@ l <<>~ m = l <%~ (<> m) l <<>= r = l <%= (<> r) {-# INLINE (<<>=) #-} +-- | ('<>') a 'Semigroup' value onto the end of the target of a 'Lens' and +-- return the result. +-- However, unlike '<<>~', it is prepend 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 t m m -> m -> s -> (m, t) +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. +-- However, unlike '<<>=', it is prepend 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/Setter.hs b/src/Control/Lens/Setter.hs index b2168cdf4..273ca95a0 100644 --- a/src/Control/Lens/Setter.hs +++ b/src/Control/Lens/Setter.hs @@ -49,11 +49,11 @@ module Control.Lens.Setter , over , set , (.~), (%~) - , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (~), (<>:~), (&&~), (<.~), (?~), (=), (&&=), (<.=), (?=), (=), (<>:=), (&&=), (<.=), (?=), (>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> :set -XNoOverloadedStrings -infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, =, ||=, %=, <.=, ?=, ~, <>:~, ||~, %~, <.~, ?~, =, <>:=, ||=, %=, <.=, ?=, ~ n = over l (<> n) l <>= a = State.modify (l <>~ a) {-# INLINE (<>=) #-} +-- | Modify the target of a 'Semigroup' value by using @('<>')@. +-- However, unlike '<>~', it is prepend to the head side. +-- +-- >>> ["world"] & id <>:~ ["hello"] +-- ["hello","world"] +-- +-- >>> (["world"], ["lens"]) & _1 <>:~ ["hello"] +-- (["hello","world"],["lens"]) +(<>:~) :: Semigroup b => ASetter s t b b -> b -> s -> t +l <>:~ n = over l (n <>) +{-# INLINE (<>:~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('<>')@. +-- However, unlike '<>=', it is prepend to the head side. +(<>:=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m () +l <>:= a = State.modify (l <>:~ a) +{-# INLINE (<>:=) #-} + ----------------------------------------------------------------------------- -- Writer Operations ----------------------------------------------------------------------------- diff --git a/tests/hunit.hs b/tests/hunit.hs index 15c502cb7..73e7880c6 100644 --- a/tests/hunit.hs +++ b/tests/hunit.hs @@ -231,6 +231,66 @@ case_append_to_state_record_field_and_access_new_value = do test = points <<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_prepend_to_record_field = + (trig & points <>:~ [ origin ]) + @?= trig { _points = [ origin ] <> (trig & _points) } + +case_prepend_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points <>:= [ origin ] + trig' = trig { _points = [ origin ] <> (trig & _points) } + +case_prepend_to_record_field_and_access_new_value = + (trig & points <<>:~ [ origin ]) + @?= ([ origin ] <> _points trig, trig { _points = [ origin ] <> (trig & _points) }) + +case_prepend_to_state_record_field_and_access_new_value = do + runState test trig @?= ([ origin ] <> _points trig, trig') + where + test = points <<>:= [ origin ] + trig' = trig { _points = [ origin ] <> (trig & _points) } + +case_cons_to_record_field = + (trig & points <|~ origin) + @?= trig { _points = origin : (trig & _points) } + +case_cons_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points <|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_cons_to_record_field_and_access_new_value = + (trig & points <<|~ origin) + @?= (origin : _points trig, trig { _points = origin : (trig & _points) }) + +case_cons_to_state_record_field_and_access_new_value = + runState test trig @?= ([ origin ] <> _points trig, trig') + where + test = points <<|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_snoc_to_record_field = + (trig & points |>~ origin) + @?= trig { _points = (trig & _points) `snoc` origin } + +case_snoc_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points |>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + +case_snoc_to_record_field_and_access_new_value = + (trig & points <|>~ origin) + @?= (_points trig `snoc` origin, trig { _points = (trig & _points) `snoc` origin }) + +case_snoc_to_state_record_field_and_access_new_value = + runState test trig @?= (_points trig <> [ origin ], trig') + where + test = points <|>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + case_append_to_record_field_and_access_old_value = (trig & points <<%~ (<>[origin])) @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] }) @@ -323,8 +383,20 @@ main = defaultMain , testCase "increment state record field" case_increment_state_record_field , testCase "append to record field" case_append_to_record_field , testCase "append to state record field" case_append_to_state_record_field + , testCase "prepend to record field" case_prepend_to_record_field + , testCase "prepend to state record field" case_prepend_to_state_record_field + , testCase "cons to record field" case_cons_to_record_field + , testCase "cons to state record field" case_cons_to_state_record_field + , testCase "snoc to record field" case_snoc_to_record_field + , testCase "snoc to state record field" case_snoc_to_state_record_field , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value + , testCase "prepend to record field and access new value" case_prepend_to_record_field_and_access_new_value + , testCase "prepend to state record field and access new value" case_prepend_to_state_record_field_and_access_new_value + , testCase "cons to record field and access new value" case_cons_to_record_field_and_access_new_value + , testCase "cons to state record field and access new value" case_cons_to_state_record_field_and_access_new_value + , testCase "snoc to record field and access new value" case_snoc_to_record_field_and_access_new_value + , 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 "read maybe map entry" case_read_maybe_map_entry