feat(Setter): add: prepends setter

src/Control/Lens/Combinators.hs

@@ -139,6 +139,12 @@ import Control.Lens hiding
  , (<?=)
  , (<>~)
  , (<>=)
+ , (<>:~)
+ , (<>:=)
+ , (<|~)
+ , (<|~)
+ , (|>~)
+ , (|>=)
  , (%@~)
  , (%@=)
  , (:>)

src/Control/Lens/Cons.hs

@@ -27,21 +27,25 @@ module Control.Lens.Cons
  , cons
  , uncons
  , _head, _tail
+ , (<|~), (<|=), (<<|~), (<<|=)
  , pattern (:<)
  -- * Snoc
  , Snoc(..)
  , (|>)
  , 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 (<|>=) #-}

src/Control/Lens/Lens.hs

@@ -87,15 +87,15 @@ module Control.Lens.Lens
  -- * Setting Functionally with Passthrough
  , (<%~), (<+~), (<-~), (<*~), (<//~)
  , (<^~), (<^^~), (<**~)
- , (<||~), (<&&~), (<<>~)
+ , (<||~), (<&&~), (<<>~), (<<>:~)
  , (<<%~), (<<.~), (<<?~), (<<+~), (<<-~), (<<*~)
  , (<<//~), (<<^~), (<<^^~), (<<**~)
  , (<<||~), (<<&&~), (<<<>~)
 
  -- * Setting State with Passthrough
  , (<%=), (<+=), (<-=), (<*=), (<//=)
  , (<^=), (<^^=), (<**=)
- , (<||=), (<&&=), (<<>=)
+ , (<||=), (<&&=), (<<>=), (<<>:=)
  , (<<%=), (<<.=), (<<?=), (<<+=), (<<-=), (<<*=)
  , (<<//=), (<<^=), (<<^^=), (<<**=)
  , (<<||=), (<<&&=), (<<<>=)
@@ -163,9 +163,9 @@ import GHC.Exts (TYPE)
 -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter"
 
 infixl 8 ^#
-infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~
+infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <<>:~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~
  , <<+~, <<-~, <<*~, <<//~, <<^~, <<^^~, <<**~, <<||~, <<&&~, <<<>~
-infix 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
 ------------------------------------------------------------------------------

src/Control/Lens/Setter.hs

@@ -49,11 +49,11 @@ module Control.Lens.Setter
  , over
  , set
  , (.~), (%~)
- , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (<?~)
+ , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (<>:~), (&&~), (<.~), (?~), (<?~)
  -- * State Combinators
  , assign, modifying
  , (.=), (%=)
- , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (&&=), (<.=), (?=), (<?=)
+ , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (<>:=), (&&=), (<.=), (?=), (<?=)
  , (<~)
  -- * Writer Combinators
  , scribe
@@ -80,8 +80,8 @@ import Prelude ()
 
 import Control.Arrow
 import Control.Comonad
-import Control.Lens.Internal.Prelude
 import Control.Lens.Internal.Indexed
+import Control.Lens.Internal.Prelude
 import Control.Lens.Internal.Setter
 import Control.Lens.Type
 import Control.Monad (liftM)
@@ -105,8 +105,8 @@ import Control.Monad.Writer.Class as Writer
 -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter"
 -- >>> :set -XNoOverloadedStrings
 
-infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, <?~
-infix 4 %@=, .@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, <.=, ?=, <?=
+infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, <>:~, ||~, %~, <.~, ?~, <?~
+infix 4 %@=, .@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, <>:=, ||=, %=, <.=, ?=, <?=
 infixr 2 <~
 
 ------------------------------------------------------------------------------
@@ -1070,6 +1070,24 @@ l <>~ 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
 -----------------------------------------------------------------------------

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