From e359e7374f0cbba1a9d30cc0a0c129de83c934e3 Mon Sep 17 00:00:00 2001
From: ncaq <ncaq@ncaq.net>
Date: Thu, 7 Mar 2024 00:18:43 +0900
Subject: [PATCH] feat: add: `<<|~`, `<<|=`, `<|>~`, `<|>=`

Add Cons operators of "with result" variants.
---
 src/Control/Lens/Cons.hs | 41 ++++++++++++++++++++++++++++++++++++----
 tests/hunit.hs           | 24 +++++++++++++++++++++++
 2 files changed, 61 insertions(+), 4 deletions(-)

diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs
index ce8d46f28..286300059 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,13 +35,14 @@ 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
@@ -81,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
@@ -342,6 +343,22 @@ l <|~ n = over l (n <|)
 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
 ------------------------------------------------------------------------------
@@ -570,3 +587,19 @@ l |>~ n = over l (|> n)
 (|>=) :: (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/tests/hunit.hs b/tests/hunit.hs
index a5e683829..f7779550c 100644
--- a/tests/hunit.hs
+++ b/tests/hunit.hs
@@ -261,6 +261,16 @@ case_cons_to_state_record_field = do
     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 }
@@ -271,6 +281,16 @@ case_snoc_to_state_record_field = do
     test = points |>= origin
     trig' = trig { _points = (trig & _points) `snoc` origin }
 
+case_snoc_to_record_field_and_access_new_value =
+  (trig & points <|>~ origin)
+    @?= ([ origin ] <> _points trig, trig { _points = (trig & _points) `snoc` origin })
+
+case_snoc_to_state_record_field_and_access_new_value =
+  runState test trig @?= ([ origin ] <> _points trig, 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 ] })
@@ -373,6 +393,10 @@ main = defaultMain
     , 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