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