diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs index 4174ee661..502680e1c 100644 --- a/src/Control/Lens/Combinators.hs +++ b/src/Control/Lens/Combinators.hs @@ -107,6 +107,7 @@ import Control.Lens hiding , (...) , (#) , (%~) + , (%!~) , (.~) , (?~) , (<.~) @@ -124,6 +125,7 @@ import Control.Lens hiding , (&&~) , (.=) , (%=) + , (%!=) , (?=) , (+=) , (-=) @@ -140,7 +142,9 @@ import Control.Lens hiding , (<>~) , (<>=) , (%@~) + , (%!@~) , (%@=) + , (%!@=) , (:>) , (:<) ) diff --git a/src/Control/Lens/Internal/Setter.hs b/src/Control/Lens/Internal/Setter.hs index 48569ff58..cb20929ab 100644 --- a/src/Control/Lens/Internal/Setter.hs +++ b/src/Control/Lens/Internal/Setter.hs @@ -49,6 +49,15 @@ instance Settable Identity where taintedDot = (Identity #.) {-# INLINE taintedDot #-} +-- CAUTION: While Data.Tuple.Solo may *look* a lot like Identity, and while we +-- *could* give it a Settable instance, we probably do not want to do so. In +-- particular, if we did, then Control.Lens.Traversal.over' would "work" with +-- Setters. But ... it wouldn't *actually* work; the mapping would end up being +-- lazy when it's supposed to be strict. Similarly, the BoxT applicative +-- transformer must not be made Settable, because that would cause a similarly +-- confusing problem with Control.Lens.Traversal.strictly. There is not, as +-- yet, any compelling reason to write such an instance, so let's not. + -- | 'Control.Lens.Fold.backwards' instance Settable f => Settable (Backwards f) where untainted = untaintedDot forwards diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs index 4ead10eb8..231a56090 100644 --- a/src/Control/Lens/Setter.hs +++ b/src/Control/Lens/Setter.hs @@ -342,9 +342,12 @@ 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'`. +-- function, which can cause space leaks in lazy fields, or when using +-- 'Control.Lens.At.ix' for value-lazy structures like 'Data.Sequence.Seq', +-- 'Data.Map.Map', 'Data.IntMap.IntMap', or 'Data.Array.Array'. For a strict +-- version, see `Control.Lens.Traversal.iover'`. -- -- @ -- 'over' :: 'Setter' s t a b -> (a -> b) -> s -> t @@ -1174,8 +1177,11 @@ ilocally l f = Reader.local (iover l f) -- @ -- -- 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'`. +-- result(s) of calling the function, which can cause space leaks in lazy +-- fields, or when using 'Control.Lens.At.ix' for value-lazy structures like +-- 'Data.Sequence.Seq', 'Data.Map.Map', 'Data.IntMap.IntMap', or +-- 'Data.Array.Array'. For a strict version, see +-- `Control.Lens.Traversal.iover'`. -- -- @ -- 'iover' :: 'IndexedSetter' 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 c4bc741e3..b56f843d1 100644 --- a/src/Control/Lens/Traversal.hs +++ b/src/Control/Lens/Traversal.hs @@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,6 +10,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} #include "lens-common.h" @@ -62,7 +67,6 @@ module Control.Lens.Traversal , mapAccumLOf, mapAccumROf , scanr1Of, scanl1Of , failover, ifailover - , over', iover' -- * Monomorphic Traversals , cloneTraversal @@ -114,6 +118,17 @@ module Control.Lens.Traversal , imapAccumROf , imapAccumLOf + -- ** Strict traversals + , over' + , (%!~) + , iover' + , (%!@~) + , modifying' + , (%!=) + , imodifying' + , (%!@=) + , strictly + -- * Reflection , traverseBy , traverseByOf @@ -146,6 +161,8 @@ import Control.Lens.Lens import Control.Lens.Setter (ASetter, AnIndexedSetter, isets, sets) import Control.Lens.Type import Control.Monad.Trans.State.Lazy +import Control.Monad.State.Class (MonadState) +import qualified Control.Monad.State.Class as MonadState import Data.Bitraversable import Data.CallStack import Data.Functor.Apply @@ -167,7 +184,7 @@ import Data.Tuple.Solo (Solo (..), getSolo) import GHC.Magic (inline) -- $setup --- >>> :set -XNoOverloadedStrings -XFlexibleContexts +-- >>> :set -XNoOverloadedStrings -XFlexibleContexts -XRankNTypes -- >>> import Data.Char (toUpper) -- >>> import Control.Applicative -- >>> import Control.Lens @@ -185,6 +202,9 @@ import GHC.Magic (inline) -- >>> let firstAndThird :: Traversal (a, x, a) (b, x, b) a b; firstAndThird = traversal go where { go :: Applicative f => (a -> f b) -> (a, x, a) -> f (b, x, b); go focus (a, x, a') = liftA3 (,,) (focus a) (pure x) (focus a') } -- >>> let selectNested :: Traversal (x, [a]) (x, [b]) a b; selectNested = traversal go where { go :: Applicative f => (a -> f b) -> (x, [a]) -> f (x, [b]); go focus (x, as) = liftA2 (,) (pure x) (traverse focus as) } +infixr 4 %!~, %!@~ +infix 4 %!=, %!@= + ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------ @@ -1471,25 +1491,170 @@ 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] = ⊥ --- @ +-- fields. See also 'strictly'. -- -- @ -- over' :: 'Lens' s t a b -> (a -> b) -> s -> t -- over' :: 'Traversal' s t a b -> (a -> b) -> s -> t -- @ +-- +-- >>> length $ over traverse id [undefined, undefined] +-- 2 +-- +-- >>> over' traverse id [1, undefined :: Int] +-- *** Exception: Prelude.undefined +-- ... over' :: LensLike Solo s t a b -> (a -> b) -> s -> t over' l f = getSolo . l (\old -> Solo $! f old) +{-# INLINE over' #-} + +-- | Traverse targets strictly. This is the operator version of 'over''. +(%!~) :: LensLike Solo s t a b -> (a -> b) -> s -> t +(%!~) = over' +{-# INLINE (%!~) #-} + +-- $ +-- >>> :{ +-- let lover' :: Lens s t a b -> (a -> b) -> s -> t +-- lover' l = over' l +-- tover' :: Traversal s t a b -> (a -> b) -> s -> t +-- tover' l = over' l +-- :} +-- +-- >>> :{ +-- let sover' :: Setter s t a b -> (a -> b) -> s -> t +-- sover' l = over' l +-- :} +-- ... +-- ...error... +-- ... -- | A version of 'Control.Lens.Setter.iover' that forces the result(s) of -- applying the function. Alternatively, an indexed version of `over'`. +-- See also 'strictly'. +-- -- @ --- iover' :: 'IndexedLens' s t a b -> (a -> b) -> s -> t --- iover' :: 'IndexedTraversal' s t a b -> (a -> b) -> s -> t +-- iover' :: IndexedLens i s t a b -> (i -> a -> b) -> s -> t +-- iover' :: IndexedTraversal i s t a b -> (i -> 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) +{-# INLINE iover' #-} + +-- | Traverse targets strictly with indices. This is the operator version of +-- 'iover''. +(%!@~) :: Over (Indexed i) Solo s t a b -> (i -> a -> b) -> s -> t +(%!@~) = iover' +{-# INLINE (%!@~) #-} + +-- | Modify the state strictly. This is stricter than +-- @Control.Lens.Setter.modifying@ in two ways: it forces the new value of the +-- state, and it forces the new value of the target within the state. +modifying' :: MonadState s m => LensLike Solo s s a b -> (a -> b) -> m () +modifying' l f = do + s <- MonadState.get + let !(Solo !t) = l (\old -> Solo $! f old) s + MonadState.put t +{-# INLINE modifying' #-} + +-- | Modify the state strictly. This is an operator version of +-- 'modifying''. +(%!=) :: MonadState s m => LensLike Solo s s a b -> (a -> b) -> m () +(%!=) = modifying' +{-# INLINE (%!=) #-} + +-- | Modify the state strictly with an index. This is stricter than +-- @Control.Lens.Setter.imodifying@ in two ways: it forces the new value of the +-- state, and it forces the new value of the target within the state. +imodifying' :: MonadState s m => Over (Indexed i) Solo s s a b -> (i -> a -> b) -> m () +imodifying' l f = do + s <- MonadState.get + let !(Solo !t) = l (Indexed $ \i old -> Solo $! f i old) s + MonadState.put t +{-# INLINE imodifying' #-} + +-- | Modify the state strictly. This is an operator version of +-- 'imodifying''. +(%!@=) :: MonadState s m => Over (Indexed i) Solo s s a b -> (i -> a -> b) -> m () +(%!@=) = imodifying' +{-# INLINE (%!@=) #-} + +-- $ +-- >>> :{ +-- let liover' :: IndexedLens i s t a b -> (i -> a -> b) -> s -> t +-- liover' l = iover' l +-- tiover' :: IndexedTraversal i s t a b -> (i -> a -> b) -> s -> t +-- tiover' l = iover' l +-- :} + +-- | Use an optic /strictly/. @strictly l f s@ will force the results of /all/ +-- the targets of @l@ before producing a new value. It does not affect folds or +-- getters. Note that producing an optic using 'strictly' will not necessarily +-- produce one even nearly as efficient as what could be written by hand, +-- although it will do so in simple enough situations. Be particularly careful +-- when working over many targets in a functor other than the usual 'Identity' +-- or @'Const' c@; things may go very well or rather badly. +-- +-- @ +-- 'over'' l = 'Control.Lens.Setter.over' (strictly l) +-- 'iover'' l = 'Control.Lens.Setter.iover' (strictly l) +-- @ +-- +-- @ +-- strictly :: 'Traversal' s t a b -> 'Traversal' s t a b +-- strictly :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b +-- @ +strictly :: (Functor f, Profunctor p, Profunctor q) => Optical p q (BoxT f) s t a b -> Optical p q f s t a b +strictly l f = rmap (fmap getSolo .# runBoxT) $ l (rmap (BoxT #. fmap (Solo $!)) f) +{-# INLINE strictly #-} + +-- $ +-- >>> :{ +-- let tstrictly :: Traversal s t a b -> Traversal s t a b +-- tstrictly l = strictly l +-- itstrictly :: AnIndexedTraversal i s t a b -> IndexedTraversal i s t a b +-- itstrictly l = strictly (cloneIndexedTraversal l) +-- lstrictly :: Lens s t a b -> Lens s t a b +-- lstrictly l = strictly l +-- ilstrictly :: AnIndexedLens i s t a b -> IndexedLens i s t a b +-- ilstrictly l = strictly (cloneIndexedLens l) +-- fstrictly :: Fold s a -> Fold s a +-- fstrictly l = strictly l +-- :} +-- +-- >>> :{ +-- let sstrictly :: Setter s t a b -> Setter s t a b +-- sstrictly l = strictly l +-- :} +-- ... +-- ...Settable ...BoxT... +-- ... + +-- | A very simple applicative transformer that gives us more control over when +-- things get forced. Note: this type /should not/ be made an instance of +-- @Settable@, because then users could accidentally use 'strictly' with a +-- 'Setter', which will not work at all. There is no way to strictify a +-- 'Setter'. +newtype BoxT f a = BoxT + { runBoxT :: f (Solo a) } + deriving (Functor, Foldable, Traversable) + +-- The Contravariant instance allows `strictly` to be used on a getter or fold. +-- It's not at all obvious that this is *useful* (since `strictly` doesn't +-- change these at all), but it's also not obviously *harmful*. +instance Contravariant f => Contravariant (BoxT f) where + contramap f (BoxT m) = BoxT $ contramap (fmap f) m +instance Apply f => Apply (BoxT f) where + liftF2 f (BoxT m) (BoxT n) = BoxT (liftF2 (liftA2 f) m n) + {-# INLINE liftF2 #-} +instance Applicative f => Applicative (BoxT f) where + pure = BoxT . pure . Solo + {-# INLINE pure #-} + BoxT m <*> BoxT n = BoxT (liftA2 (<*>) m n) + {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 f (BoxT m) (BoxT n) = BoxT (liftA2 (liftA2 f) m n) + {-# INLINE liftA2 #-} +#endif + -- Caution: We *can't* implement *> or <* in terms of the underlying *> and + -- <*. We need to force the Solos, not discard them.