From dae984dbebed956ccbda62dc658838a127cc9981 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Wed, 21 Dec 2022 03:27:23 -0500
Subject: [PATCH] Add strict over variants

Add `over'` and `iover'`, which force the result(s) of applying
the passed function.

Closes #1016
---
 lens.cabal                    |  1 +
 src/Control/Lens/Setter.hs    |  8 ++++++++
 src/Control/Lens/Traversal.hs | 27 +++++++++++++++++++++++++++
 3 files changed, 36 insertions(+)

diff --git a/lens.cabal b/lens.cabal
index 6acf6115f..9c1f0052f 100644
--- a/lens.cabal
+++ b/lens.cabal
@@ -190,6 +190,7 @@ library
     indexed-traversable-instances >= 0.1      && < 0.2,
     kan-extensions                >= 5        && < 6,
     mtl                           >= 2.2.1    && < 2.4,
+    OneTuple                      >= 0.3      && < 0.4,
     parallel                      >= 3.2.1.0  && < 3.3,
     profunctors                   >= 5.5.2    && < 6,
     reflection                    >= 2.1      && < 3,
diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs
index b2168cdf4..4ead10eb8 100644
--- a/src/Control/Lens/Setter.hs
+++ b/src/Control/Lens/Setter.hs
@@ -342,6 +342,10 @@ cloneIndexedSetter l pafb = taintedDot (runIdentity #. l (Indexed $ \i -> Identi
 -- >>> over _1 show (10,20)
 -- ("10",20)
 --
+-- Like 'fmap', @over@ is normally lazy in the result(s) of calling the
+-- function, which can cause space leaks under some circumstances. For a strict
+-- version, see `Control.Lens.Traversal.over'`.
+--
 -- @
 -- 'over' :: 'Setter' s t a b -> (a -> b) -> s -> t
 -- 'over' :: 'ASetter' s t a b -> (a -> b) -> s -> t
@@ -1169,6 +1173,10 @@ ilocally l f = Reader.local (iover l f)
 -- 'iover' l ≡ 'over' l '.' 'Indexed'
 -- @
 --
+-- Like 'Data.Functor.WithIndex.imap', @iover@ is normally lazy in the
+-- result(s) of calling the function, which can cause space leaks under some
+-- circumstances. For a strict version, see `Control.Lens.Traversal.iover'`.
+--
 -- @
 -- 'iover' :: 'IndexedSetter' i s t a b    -> (i -> a -> b) -> s -> t
 -- 'iover' :: 'IndexedLens' i s t a b      -> (i -> a -> b) -> s -> t
diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs
index 1b1d57e6d..c4bc741e3 100644
--- a/src/Control/Lens/Traversal.hs
+++ b/src/Control/Lens/Traversal.hs
@@ -62,6 +62,7 @@ module Control.Lens.Traversal
   , mapAccumLOf, mapAccumROf
   , scanr1Of, scanl1Of
   , failover, ifailover
+  , over', iover'
 
   -- * Monomorphic Traversals
   , cloneTraversal
@@ -162,6 +163,7 @@ import Data.Reflection
 import Data.Semigroup.Traversable
 import Data.Semigroup.Bitraversable
 import Data.Tuple (swap)
+import Data.Tuple.Solo (Solo (..), getSolo)
 import GHC.Magic (inline)
 
 -- $setup
@@ -1466,3 +1468,28 @@ traverseByOf l pur app f = reifyApplicative pur app (l (ReflectedApplicative #.
 -- @
 sequenceByOf :: Traversal s t (f b) b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> s -> f t
 sequenceByOf l pur app = reifyApplicative pur app (l ReflectedApplicative)
+
+-- | A version of 'Control.Lens.Setter.over' that forces the result(s) of
+-- applying the function. This can prevent space leaks when modifying lazy
+-- fields.
+--
+-- @
+-- over traverse (const ⊥) [1,2] = [⊥, ⊥]
+-- over' traverse (const ⊥) [1,2] = ⊥
+-- @
+--
+-- @
+-- over' :: 'Lens' s t a b -> (a -> b) -> s -> t
+-- over' :: 'Traversal' s t a b -> (a -> b) -> s -> t
+-- @
+over' :: LensLike Solo s t a b -> (a -> b) -> s -> t
+over' l f = getSolo . l (\old -> Solo $! f old)
+
+-- | A version of 'Control.Lens.Setter.iover' that forces the result(s) of
+-- applying the function. Alternatively, an indexed version of `over'`.
+-- @
+-- iover' :: 'IndexedLens' s t a b -> (a -> b) -> s -> t
+-- iover' :: 'IndexedTraversal' s t a b -> (a -> b) -> s -> t
+-- @
+iover' :: Over (Indexed i) Solo s t a b -> (i -> a -> b) -> s -> t
+iover' l f = getSolo . l (Indexed $ \i a -> Solo $! f i a)