feat(Setter): add: prepends setter

Add a setter that prepends the element, like `cons`.
For balance, we also add a setter that also appends the element to the tail, like `snoc`.
We often use this when adding elements to list structures and other order-conscious things.
When we are doing natural language processing, for example, and we are adding processed data, it is more natural to add the resulting processed data to the head side if the original input source is closer to the head.
Naturally we can also construct the processing by adding the tail if we think hard enough, but we don't want to work hard at that since we only need to prepare a function.
The naming of the `<>:~` function was lost with `~<>`, but considering that the `~` symbol in the lenses setter operator is basically on the right, I used the `:` operator to indicate that it is closer to the `cons` of the list, rather than focusing on the contrast.

src/Control/Lens/Combinators.hs

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

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,9 @@ import Prelude ()
 
 import Control.Arrow
 import Control.Comonad
-import Control.Lens.Internal.Prelude
+import Control.Lens.Cons
 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 +106,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 +1071,50 @@ 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 (<>:=) #-}
+
+-- | 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 (<|=) #-}
+
+-- | 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 (|>=) #-}
+
 -----------------------------------------------------------------------------
 -- Writer Operations
 -----------------------------------------------------------------------------

tests/hunit.hs

@@ -221,6 +221,36 @@ case_append_to_state_record_field = 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_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_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_append_to_record_field_and_access_new_value =
   (trig & points <<>~ [ origin ])
     @?= (_points trig <> [ origin ], trig { _points = (trig & _points) <> [ origin ] })
@@ -323,6 +353,12 @@ 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 "append to record field and access old value" case_append_to_record_field_and_access_old_value