packages feed

lens 5.2.3 → 5.3.6

raw patch · 29 files changed

Files

CHANGELOG.markdown view
@@ -1,3 +1,78 @@+5.3.6 [2026.01.10]+------------------+* Allow building with `template-haskell-2.24.*` (GHC 9.14).+* Add `_SpecialiseEP` to `Language.Haskell.TH.Lens` (when building with+  `template-haskell-2.24.*`/GHC 9.14 or later).++5.3.5 [2025.06.17]+------------------+* Replace `test-framework` with `tasty` in the test suite.++5.3.4 [2025.03.03]+------------------+* Reduce the arity of `foldr1Of`, `foldl1Of`, `foldrOf'`, `foldlOf'`,+  `foldr1Of'`, `foldl1Of'`, `foldrMOf`, and `foldlMOf` so that GHC is more+  eager to inline them. On a simple benchmark involving `sumOf` (defined in+  terms of `foldlOf'`), this improves performance by 8x.+* Add `Ixed`, `Cons`, `Each`, `AsEmpty`, `Reversing`, and `Rewrapped` instances+  for strict boxed vectors when building with `vector-0.13.2` or later.+* Add an `AsEmpty` instance for primitive `Vector`s.++5.3.3 [2024.12.28]+------------------+* Add `makeFieldsId`, which generates overloaded field accessors using the+  same names as the underlying fields. This is intended for use with the+  `NoFieldSelectors` and `DuplicateRecordFields` language extensions.++  Also add `classIdFields :: LensRules` and `classIdNamer :: FieldNamer`, both+  of which use the same naming rules as `makeFieldsId`.+* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to+  `template-haskell-2.23.0.0`:+  * Add an `_OrP` `Prism` for the `Pat` data type.+  * Add `_ForallE`, `_ForallVisE`, and `_ConstrainedE` `Prism`s for the `Exp`+    data type.++5.3.2 [2024.05.12]+------------------+* Define the following lenses that perform an operation and result the old+  result:+  * `(<<<>:~)` (prepend to the front via `(<>)` and return the old result)+  * `(<<<|~)` (prepend to the front via `(<|)` and return the old result)+  * `(<<|>~)` (append to the back via `(|>)` and return the old result)++  Each of these also has a variant that end with `=` instead of `~` (e.g.,+  `(<<<>:=)`) for working in a `MonadState` setting.+* Re-export `(<>:~)`, `(<<>:~)`, `(<|~)`, `(<<|~)`, `(|>~)`, and `(<|>~)` (as+  well as their variants which end with `=` instead of `~`, and their variants+  which return the old result) from `Control.Lens.Operators`.++5.3.1 [2024.05.05]+------------------+* Add a `Magnify` instance for the CPS variant of `RWST` when building with+  `mtl-2.3` or later.++5.3 [2024.05.04]+----------------+* Allow building with GHC 9.10.+* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to+  `template-haskell-2.22.0.0`:+  * The `_InfixD` `Prism` now focuses on `(Fixity, NamespaceSpecifier, Name)`+    when building with `template-haskell-2.22.0.0` or later.+  * Add `Prism`s for the newly introduced `NamespaceSpecifier` data type.+  * Add `_TypeP` and `_InvisP` `Prism`s for the `Pat` data type.+  * Add a `_TypeE` `Prism` for the `Exp` data type.+  * Add a `_SCCP` `Prism` for the `Pragma` data type.+* Add the following `Setter`s for prepending and appending elements:+  * `(<>:~)`: prepend an element to the front via `(<>)`.+  * `(<<>:~)`: prepend an element to the front via `(<>)` and return the result.+  * `(<|~)`: cons an element to the front via `(<|)`.+  * `(<<|~)`: cons an element to the front via `(<|)` and return the result.+  * `(|>~)`: snoc an element to the back via `(|>)`.+  * `(<|>~)`: snoc an element to the back via `(|>)` and return the result.++  Each of these also has a variant that end with `=` instead of `~` (e.g.,+  `(<>:=)`) for working in a `MonadState` setting.+ 5.2.3 [2023.08.24] ------------------ * Allow building with GHC 9.8.
README.markdown view
@@ -9,7 +9,7 @@  The [FAQ](https://github.com/ekmett/lens/wiki/FAQ), which provides links to a large number of different resources for learning about lenses and an overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [overview](https://github.com/ekmett/lens/wiki/Overview) and some [examples](https://github.com/ekmett/lens/wiki/Examples). -Documentation is available through [github](http://ekmett.github.com/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases.+Documentation is available through [github](https://ekmett.github.io/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases.  Field Guide -----------
benchmarks/folds.hs view
@@ -31,6 +31,10 @@       [ bench "native"     $ nf (V.toList . V.indexed) v       , bench "itraversed" $ nf (itoListOf itraversed) v       ]+    , bgroup "sum"+      [ bench "native" $ whnf V.sum v+      , bench "each"   $ whnf (sumOf each) v+      ]     ]   , bgroup "unboxed-vector"     [ bgroup "toList"@@ -41,6 +45,10 @@       [ bench "native"     $ nf (U.toList . U.indexed) u       , bench "vTraverse" $ nf (itoListOf vectorTraverse) u       ]+    , bgroup "sum"+      [ bench "native" $ whnf U.sum u+      , bench "each"   $ whnf (sumOf each) u+      ]     ]   , bgroup "sequence"     [ bgroup "toList"@@ -71,6 +79,10 @@     , bgroup "itoList"       [ bench "native"     $ nf (zip [(0::Int)..]) l       , bench "itraversed" $ nf (itoListOf itraversed) l+      ]+    , bgroup "sum"+      [ bench "native" $ whnf sum l+      , bench "each"   $ whnf (sumOf each) l       ]     ]   , bgroup "map"
benchmarks/plated.hs view
@@ -4,13 +4,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Main (main) where -#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--import Prelude ()-import Prelude.Compat- import           Control.Lens import           Control.DeepSeq import           Criterion.Main
cabal.project view
@@ -1,7 +1,3 @@ packages: .           ./examples           ./lens-properties---- For GHC-9.6-allow-newer: vector-th-unbox-0.2.2:base-allow-newer: vector-th-unbox-0.2.2:template-haskell
examples/lens-examples.cabal view
@@ -24,13 +24,16 @@              , GHC == 8.10.7              , GHC == 9.0.2              , GHC == 9.2.8-             , GHC == 9.4.5-             , GHC == 9.6.2-             , GHC == 9.8.1+             , GHC == 9.4.8+             , GHC == 9.6.7+             , GHC == 9.8.4+             , GHC == 9.10.3+             , GHC == 9.12.2+             , GHC == 9.14.1  source-repository head   type: git-  location: git://github.com/ekmett/lens.git+  location: https://github.com/ekmett/lens.git  flag pong   default: True@@ -42,10 +45,9 @@     Turtle   build-depends:     aeson,-    base       >= 4.5      && < 5,+    base       >= 4.9      && < 5,     bytestring >= 0.9.1.10 && < 0.13,     data-default-class,-    ghc-prim,     lens   default-language: Haskell2010   ghc-options: -Wall@@ -55,12 +57,12 @@     buildable: False    build-depends:-    base       >= 4.5   && < 5,-    containers >= 0.4   && < 0.7,+    base       >= 4.9   && < 5,+    containers >= 0.4   && < 0.9,     gloss      >= 1.12  && < 1.14,     lens,     mtl        >= 2.0.1 && < 2.4,-    random     >= 1.0   && < 1.3,+    random     >= 1.0   && < 1.4,     streams    >= 3.3   && < 4   main-is: Pong.hs   default-language: Haskell2010
lens-properties/lens-properties.cabal view
@@ -21,9 +21,12 @@              , GHC == 8.10.7              , GHC == 9.0.2              , GHC == 9.2.8-             , GHC == 9.4.5-             , GHC == 9.6.2-             , GHC == 9.8.1+             , GHC == 9.4.8+             , GHC == 9.6.7+             , GHC == 9.8.4+             , GHC == 9.10.3+             , GHC == 9.12.2+             , GHC == 9.14.1  extra-source-files:   .hlint.yaml@@ -31,13 +34,13 @@  source-repository head   type: git-  location: git://github.com/ekmett/lens.git+  location: https://github.com/ekmett/lens.git  library   build-depends:     base         >= 4.9 && < 5,     lens         >= 4   && < 6,-    QuickCheck   >= 2.4 && < 2.15,+    QuickCheck   >= 2.4 && < 2.18,     transformers >= 0.2 && < 0.7    exposed-modules:
lens.cabal view
@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses, Generics-version:       5.2.3+version:       5.3.6 license:       BSD2 cabal-version: 1.18 license-file:  LICENSE@@ -20,9 +20,12 @@              , GHC == 8.10.7              , GHC == 9.0.2              , GHC == 9.2.8-             , GHC == 9.4.5-             , GHC == 9.6.2-             , GHC == 9.8.1+             , GHC == 9.4.8+             , GHC == 9.6.7+             , GHC == 9.8.4+             , GHC == 9.10.3+             , GHC == 9.12.2+             , GHC == 9.14.1 synopsis:      Lenses, Folds and Traversals description:   This package comes \"Batteries Included\" with many useful lenses for the types@@ -35,7 +38,7 @@   .   An overview, with a large number of examples can be found in the <https://github.com/ekmett/lens#lens-lenses-folds-and-traversals README>.   .-  An introductory video on the style of code used in this library by Simon Peyton Jones is available from <http://skillsmatter.com/podcast/scala/lenses-compositional-data-access-and-manipulation Skills Matter>.+  An introductory video on the style of code used in this library by Simon Peyton Jones is available from <https://archive.org/details/lenses-compositional-data-access-and-manipulation-simon-peyton-jones-at-haskell- Internet Archive>.   .   A video on how to use lenses and how they are constructed is available on <http://youtu.be/cefnmjtAolY?hd=1 youtube>.   .@@ -51,9 +54,7 @@   With some signatures simplified, the core of the hierarchy of lens-like constructions looks like:   .   .-  <<http://i.imgur.com/ALlbPRa.png>>-  .-  <https://raw.githubusercontent.com/ekmett/lens/master/images/Hierarchy.png (Local Copy)>+  <<https://raw.githubusercontent.com/ekmett/lens/master/images/Hierarchy.png>>   .   You can compose any two elements of the hierarchy above using @(.)@ from the @Prelude@, and you can   use any element of the hierarchy as any type it linked to above it.@@ -181,30 +182,28 @@     bytestring                    >= 0.10.4.0 && < 0.13,     call-stack                    >= 0.1      && < 0.5,     comonad                       >= 5.0.7    && < 6,-    containers                    >= 0.5.5.1  && < 0.7,+    containers                    >= 0.5.5.1  && < 0.9,     contravariant                 >= 1.4      && < 2,     distributive                  >= 0.5.1    && < 1,     exceptions                    >= 0.8.2.1  && < 1,-    filepath                      >= 1.2.0.0  && < 1.5,+    filepath                      >= 1.2.0.0  && < 1.6,     free                          >= 5.1.5    && < 6,-    ghc-prim,-    hashable                      >= 1.2.7.0  && < 1.5,+    hashable                      >= 1.2.7.0  && < 1.6,     indexed-traversable           >= 0.1      && < 0.2,     indexed-traversable-instances >= 0.1      && < 0.2,     kan-extensions                >= 5        && < 6,     mtl                           >= 2.2.1    && < 2.4,-    parallel                      >= 3.2.1.0  && < 3.3,+    parallel                      >= 3.2.1.0  && < 3.4,     profunctors                   >= 5.5.2    && < 6,     reflection                    >= 2.1      && < 3,     semigroupoids                 >= 5.0.1    && < 7,     strict                        >= 0.4      && < 0.6,     tagged                        >= 0.8.6    && < 1,-    template-haskell              >= 2.11.1.0 && < 2.22,-    text                          >= 1.2.3.0  && < 2.1,-    th-abstraction                >= 0.4.1    && < 0.7,+    template-haskell              >= 2.11.1.0 && < 2.25,+    text                          >= 1.2.3.0  && < 2.2,+    th-abstraction                >= 0.4.1    && < 0.8,     these                         >= 1.1.1.1  && < 1.3,     transformers                  >= 0.5.0.0  && < 0.7,-    transformers-compat           >= 0.5.0.4  && < 1,     unordered-containers          >= 0.2.10   && < 0.3,     vector                        >= 0.12.1.2 && < 0.14 @@ -332,6 +331,9 @@     T799     T917     T972+  if impl(ghc >= 9.2)+    other-modules:+      T1024   ghc-options: -Wall -threaded   hs-source-dirs: tests   default-language: Haskell2010@@ -362,9 +364,9 @@     build-depends:       base,       lens,-      QuickCheck                 >= 2.4,-      test-framework             >= 0.6,-      test-framework-quickcheck2 >= 0.2,+      QuickCheck >= 2.4,+      tasty >= 1.4 && < 1.6,+      tasty-quickcheck >= 0.10 && < 0.12,       transformers  test-suite hunit@@ -380,13 +382,12 @@     build-depends:       base,       containers,-      HUnit >= 1.2,       lens,       mtl,       text,       bytestring,-      test-framework       >= 0.6,-      test-framework-hunit >= 0.2+      tasty >= 1.4 && < 1.6,+      tasty-hunit >= 0.10 && < 0.11  -- We need this dummy test-suite to add simple-reflect to the install plan --@@ -398,7 +399,7 @@   hs-source-dirs:    tests   default-language:  Haskell2010 -  build-depends: base, deepseq, simple-reflect >= 0.3.1+  build-depends: base <5, deepseq, simple-reflect >= 0.3.1  -- Basic benchmarks for the uniplate-style combinators benchmark plated@@ -409,7 +410,6 @@   default-language: Haskell2010   build-depends:     base,-    base-compat >=0.11.0 && <0.14,     comonad,     criterion,     deepseq,
src/Control/Exception/Lens.hs view
@@ -166,11 +166,17 @@   , Bool(..)   ) --- $setup--- >>> :set -XNoOverloadedStrings--- >>> import Control.Lens--- >>> import Control.Applicative--- >>> :m + Control.Exception Control.Monad Data.List Prelude+{-+$setup+>>> :set -XNoOverloadedStrings+>>> :set -XScopedTypeVariables+>>> import Control.Lens+>>> import Control.Applicative+>>> :m + Control.Exception Control.Monad Data.List Prelude+#if MIN_VERSION_base(4,20,0)+>>> :m + Control.Exception.Context+#endif+-}  ------------------------------------------------------------------------------ -- Exceptions as Prisms@@ -674,15 +680,21 @@   -- @   __AssertionFailed :: Prism' t AssertionFailed -  -- | This t'Exception' contains provides information about what assertion failed in the 'String'.-  --+  {- | This t'Exception' contains provides information about what assertion failed in the 'String'.++  @+  '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String'+  '_AssertionFailed' :: 'Prism'' 'SomeException'   'String'+  @++#if MIN_VERSION_base(4,20,0)+  >>> handling exception (\ (ExceptionWithContext ctxt (_ :: AssertionFailed)) -> "caught" <$ guard ("<interactive>" `isInfixOf` displayExceptionContext ctxt) ) $ assert False (return "uncaught")+  "caught"+#else   -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("<interactive>" `isInfixOf` xs) ) $ assert False (return "uncaught")   -- "caught"-  ---  -- @-  -- '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String'-  -- '_AssertionFailed' :: 'Prism'' 'SomeException'   'String'-  -- @+#endif+  -}   _AssertionFailed :: Prism' t String   _AssertionFailed = __AssertionFailed._AssertionFailed   {-# INLINE _AssertionFailed #-}
src/Control/Lens/At.hs view
@@ -85,6 +85,9 @@ import qualified Data.Vector.Storable as Storable import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox)+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Data.Word import Foreign.Storable (Storable) @@ -113,6 +116,9 @@ type instance Index (Prim.Vector a) = Int type instance Index (Storable.Vector a) = Int type instance Index (Unboxed.Vector a) = Int+#if MIN_VERSION_vector(0,13,2)+type instance Index (VectorStrict.Vector a) = Int+#endif type instance Index (Complex a) = Int type instance Index (Identity a) = () type instance Index (Maybe a) = ()@@ -395,6 +401,15 @@     | 0 <= i && i < Unboxed.length v = f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]     | otherwise                      = pure v   {-# INLINE ix #-}++#if MIN_VERSION_vector(0,13,2)+type instance IxValue (VectorStrict.Vector a) = a+instance Ixed (VectorStrict.Vector a) where+  ix i f v+    | 0 <= i && i < VectorStrict.length v = f (v VectorStrict.! i) <&> \a -> v VectorStrict.// [(i, a)]+    | otherwise                           = pure v+  {-# INLINE ix #-}+#endif  type instance IxValue StrictT.Text = Char instance Ixed StrictT.Text where
src/Control/Lens/Combinators.hs view
@@ -139,6 +139,18 @@   , (<?=)   , (<>~)   , (<>=)+  , (<>:~)+  , (<>:=)+  , (<<>:~)+  , (<<>:=)+  , (<|~)+  , (<|=)+  , (<<|~)+  , (<<|=)+  , (|>~)+  , (|>=)+  , (<|>~)+  , (<|>=)   , (%@~)   , (%@=)   , (:>)
src/Control/Lens/Cons.hs view
@@ -27,6 +27,7 @@   , cons   , uncons   , _head, _tail+  , (<|~), (<|=), (<<|~), (<<|=), (<<<|~), (<<<|=)   , pattern (:<)   -- * Snoc   , Snoc(..)@@ -34,14 +35,17 @@   , 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@@ -60,8 +64,12 @@ import qualified Data.Vector.Primitive as Prim import           Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import           Data.Word import           Control.Applicative (ZipList(..))+import           Control.Monad.State.Class as State import           Prelude  -- $setup@@ -77,6 +85,8 @@  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@@ -173,6 +183,15 @@     else Right (Unbox.unsafeHead v, Unbox.unsafeTail v)   {-# INLINE _Cons #-} +#if MIN_VERSION_vector(0,13,2)+instance Cons (VectorStrict.Vector a) (VectorStrict.Vector b) a b where+  _Cons = prism (uncurry VectorStrict.cons) $ \v ->+    if VectorStrict.null v+    then Left VectorStrict.empty+    else Right (VectorStrict.unsafeHead v, VectorStrict.unsafeTail v)+  {-# INLINE _Cons #-}+#endif+ -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'.@@ -323,6 +342,49 @@ _tail = _Cons._2 {-# INLINE _tail #-} +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' 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' using @('<|')@.+(<|=) :: (MonadState s m, Cons b b a a) => ASetter s s b b -> a -> m ()+l <|= a = State.modify (l <|~ a)+{-# INLINE (<|=) #-}++-- | ('<|') a value onto 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 value onto the target of a 'Lens' and return the /old/ 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 b -> a -> s -> (b, s)+l <<<|~ m = l <<%~ (m <|)+{-# INLINE (<<<|~) #-}++-- | ('<|') a value onto 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 (<<|=) #-}++-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and+-- return the /old/ 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 ------------------------------------------------------------------------------@@ -492,7 +554,7 @@ _last = _Snoc._2 {-# INLINE _last #-} --- | 'snoc' an element onto the end of a container.+-- | 'snoc' an element onto a container. -- -- This is an infix alias for 'snoc'. --@@ -508,7 +570,7 @@ (|>) = curry (simply review _Snoc) {-# INLINE (|>) #-} --- | 'snoc' an element onto the end of a container.+-- | 'snoc' an element onto a container. -- -- >>> snoc (Seq.fromList []) a -- fromList [a]@@ -538,3 +600,46 @@ unsnoc :: Snoc s s a a => s -> Maybe (s, a) unsnoc = simply preview _Snoc {-# INLINE unsnoc #-}++-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' 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' using @('|>')@.+(|>=) :: (MonadState s m, Snoc b b a a) => ASetter s s b b -> a -> m ()+l |>= a = State.modify (l |>~ a)+{-# INLINE (|>=) #-}++-- | ('|>') a value onto 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 value onto the target of a 'Lens' and return the /old/ 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 b -> p -> s -> (b, s)+l <<|>~ m = l <<%~ (|> m)+{-# INLINE (<<|>~) #-}++-- | ('|>') a value onto 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 (<|>=) #-}++-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and+-- return the /old/ 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/Each.hs view
@@ -54,6 +54,9 @@ import qualified Data.Vector.Storable as Storable import Data.Vector.Storable (Storable) import qualified Data.Vector.Unboxed as Unboxed+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Data.Vector.Unboxed (Unbox) import Data.Word import qualified Data.Strict as S@@ -194,6 +197,13 @@ instance (Unbox a, Unbox b) => Each (Unboxed.Vector a) (Unboxed.Vector b) a b where   each = vectorTraverse   {-# INLINE each #-}++#if MIN_VERSION_vector(0,13,2)+-- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@+instance Each (VectorStrict.Vector a) (VectorStrict.Vector b) a b where+  each = vectorTraverse+  {-# INLINE each #-}+#endif  -- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@ instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where
src/Control/Lens/Empty.hs view
@@ -53,6 +53,10 @@ import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Storable as Storable+import qualified Data.Vector.Primitive as Prim+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Foreign.Storable (Storable)  #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS)@@ -161,9 +165,19 @@   _Empty = nearly Unboxed.empty Unboxed.null   {-# INLINE _Empty #-} +instance Prim.Prim a => AsEmpty (Prim.Vector a) where+  _Empty = nearly Prim.empty Prim.null+  {-# INLINE _Empty #-}+ instance Storable a => AsEmpty (Storable.Vector a) where   _Empty = nearly Storable.empty Storable.null   {-# INLINE _Empty #-}++#if MIN_VERSION_vector(0,13,2)+instance AsEmpty (VectorStrict.Vector a) where+  _Empty = nearly VectorStrict.empty VectorStrict.null+  {-# INLINE _Empty #-}+#endif  instance AsEmpty (Seq.Seq a) where   _Empty = nearly Seq.empty Seq.null
src/Control/Lens/Fold.hs view
@@ -1754,8 +1754,9 @@ -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of :: HasCallStack => Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a-foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure")-                            (foldrOf l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldr1Of l f = fromMaybe (error "foldr1Of: empty structure")+             . foldrOf l mf Nothing where   mf x my = Just $ case my of     Nothing -> x     Just y -> f x y@@ -1780,7 +1781,8 @@ -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of :: HasCallStack => Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a-foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldl1Of l f = fromMaybe (error "foldl1Of: empty structure") . foldlOf l mf Nothing where   mf mx y = Just $ case mx of     Nothing -> y     Just x  -> f x y@@ -1800,7 +1802,8 @@ -- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r-foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0+-- See: NOTE: [Inlining and arity]+foldrOf' l f z0 = \xs -> foldlOf l f' (Endo id) xs `appEndo` z0   where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldrOf' #-} @@ -1818,7 +1821,8 @@ -- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r-foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0+-- See: NOTE: [Inlining and arity]+foldlOf' l f z0 = \xs -> foldrOf l f' (Endo id) xs `appEndo` z0   where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} @@ -1838,7 +1842,8 @@ -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of' :: HasCallStack => Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a-foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldr1Of' l f = fromMaybe (error "foldr1Of': empty structure") . foldrOf' l mf Nothing where   mf x Nothing = Just $! x   mf x (Just y) = Just $! f x y {-# INLINE foldr1Of' #-}@@ -1859,7 +1864,8 @@ -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of' :: HasCallStack => Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a-foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldl1Of' l f = fromMaybe (error "foldl1Of': empty structure") . foldlOf' l mf Nothing where   mf Nothing y = Just $! y   mf (Just x) y = Just $! f x y {-# INLINE foldl1Of' #-}@@ -1881,7 +1887,8 @@ foldrMOf :: Monad m          => Getting (Dual (Endo (r -> m r))) s a          -> (a -> r -> m r) -> r -> s -> m r-foldrMOf l f z0 xs = foldlOf l f' return xs z0+-- See: NOTE: [Inlining and arity]+foldrMOf l f z0 = \xs -> foldlOf l f' return xs z0   where f' k x z = f x z >>= k {-# INLINE foldrMOf #-} @@ -1902,9 +1909,25 @@ foldlMOf :: Monad m          => Getting (Endo (r -> m r)) s a          -> (r -> a -> m r) -> r -> s -> m r-foldlMOf l f z0 xs = foldrOf l f' return xs z0+-- See: NOTE: [Inlining and arity]+foldlMOf l f z0 = \xs -> foldrOf l f' return xs z0   where f' x k z = f z x >>= k {-# INLINE foldlMOf #-}++-- NOTE: [Inlining and arity]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- GHC uses the following inlining heuristic: a function body is inlined if+-- all its arguments on the LHS are applied. So the following two definitions+-- are not equivalent from the inliner's PoV:+--+-- > foldlOf' l f z0 xs = ...+-- > foldlOf' l f z0 = \xs -> ...+--+-- GHC will be less eager to inline the first one and this results in+-- worse code. For example, a simple list summation using `sumOf` will be 8x slower+-- with the first version.+  -- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries. --
src/Control/Lens/Internal/Iso.hs view
@@ -33,6 +33,9 @@ import qualified Data.Vector.Storable  as Storable import qualified Data.Vector.Unboxed   as Unbox import Data.Vector.Unboxed (Unbox)+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import qualified Data.Sequence         as Seq import Data.Sequence (Seq) import Foreign.Storable (Storable)@@ -100,3 +103,8 @@  instance Storable a => Reversing (Storable.Vector a) where   reversing = Storable.reverse++#if MIN_VERSION_vector(0,13,2)+instance Reversing (VectorStrict.Vector a) where+  reversing = VectorStrict.reverse+#endif
src/Control/Lens/Lens.hs view
@@ -87,18 +87,18 @@   -- * Setting Functionally with Passthrough   , (<%~), (<+~), (<-~), (<*~), (<//~)   , (<^~), (<^^~), (<**~)-  , (<||~), (<&&~), (<<>~)+  , (<||~), (<&&~), (<<>~), (<<>:~)   , (<<%~), (<<.~), (<<?~), (<<+~), (<<-~), (<<*~)   , (<<//~), (<<^~), (<<^^~), (<<**~)-  , (<<||~), (<<&&~), (<<<>~)+  , (<<||~), (<<&&~), (<<<>~), (<<<>:~)    -- * Setting State with Passthrough   , (<%=), (<+=), (<-=), (<*=), (<//=)   , (<^=), (<^^=), (<**=)-  , (<||=), (<&&=), (<<>=)+  , (<||=), (<&&=), (<<>=), (<<>:=)   , (<<%=), (<<.=), (<<?=), (<<+=), (<<-=), (<<*=)   , (<<//=), (<<^=), (<<^^=), (<<**=)-  , (<<||=), (<<&&=), (<<<>=)+  , (<<||=), (<<&&=), (<<<>=), (<<<>:=)   , (<<~)    -- * Cloning Lenses@@ -163,10 +163,10 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter"  infixl 8 ^#-infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~-       , <<+~, <<-~, <<*~, <<//~, <<^~, <<^^~, <<**~, <<||~, <<&&~, <<<>~-infix  4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.=, <<?=, <#=, #=, #%=, <#%=, #%%=-       , <<+=, <<-=, <<*=, <<//=, <<^=, <<^^=, <<**=, <<||=, <<&&=, <<<>=+infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <<>:~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~+       , <<+~, <<-~, <<*~, <<//~, <<^~, <<^^~, <<**~, <<||~, <<&&~, <<<>~, <<<>:~+infix  4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <<>:=, <%=, <<%=, <<.=, <<?=, <#=, #=, #%=, <#%=, #%%=+       , <<+=, <<-=, <<*=, <<//=, <<^=, <<^^=, <<**=, <<||=, <<&&=, <<<>=, <<<>:= infixr 2 <<~ infixl 1 ??, &~ @@ -1191,6 +1191,42 @@ (<<>=) :: (MonadState s m, Semigroup r) => LensLike' ((,)r) s r -> r -> m r l <<>= r = l <%= (<> r) {-# INLINE (<<>=) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and+-- return the result.+-- However, unlike ('<<>~'), it is prepended 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 front of the target of a 'Lens' and+-- return the /old/ result.+-- However, unlike ('<<>~'), it is prepended 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 m -> m -> s -> (m, s)+l <<<>:~ m = l <<%~ (m <>)+{-# INLINE (<<<>:~) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into+-- your 'Monad''s state and return the result.+-- However, unlike ('<<>='), it is prepended 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 (<<>:=) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into+-- your 'Monad''s state and return the /old/ result.+-- However, unlike ('<<<>='), it is prepended 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/Operators.hs view
@@ -18,6 +18,18 @@   -- * "Control.Lens.Cons"     (<|)   , (|>)+  , (<|~)+  , (<|=)+  , (<<|~)+  , (<<|=)+  , (<<<|~)+  , (<<<|=)+  , (|>~)+  , (|>=)+  , (<|>~)+  , (<|>=)+  , (<<|>~)+  , (<<|>=)   -- * "Control.Lens.Fold"   , (^..)   , (^?)@@ -62,6 +74,7 @@   , (<<||~)   , (<<&&~)   , (<<<>~)+  , (<<<>:~)   , (<%=)   , (<+=)   , (<-=)@@ -85,9 +98,12 @@   , (<<||=)   , (<<&&=)   , (<<<>=)+  , (<<<>:=)   , (<<~)   , (<<>~)   , (<<>=)+  , (<<>:~)+  , (<<>:=)   , (<%@~)   , (<<%@~)   , (%%@~)@@ -141,6 +157,8 @@   , (<?=)   , (<>~)   , (<>=)+  , (<>:~)+  , (<>:=)   , (.@~)   , (.@=)   , (%@~)
src/Control/Lens/Setter.hs view
@@ -49,11 +49,11 @@   , over   , set   , (.~), (%~)-  , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (<?~)+  , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (<>:~), (&&~), (<.~), (?~), (<?~)   -- * State Combinators   , assign, modifying   , (.=), (%=)-  , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (&&=), (<.=), (?=), (<?=)+  , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (<>:=), (&&=), (<.=), (?=), (<?=)   , (<~)   -- * Writer Combinators   , scribe@@ -80,8 +80,8 @@  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 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> :set -XNoOverloadedStrings -infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, <?~-infix  4 %@=, .@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, <.=, ?=, <?=+infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, <>:~, ||~, %~, <.~, ?~, <?~+infix  4 %@=, .@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, <>:=, ||=, %=, <.=, ?=, <?= infixr 2 <~  ------------------------------------------------------------------------------@@ -1069,6 +1069,24 @@ (<>=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m () 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
src/Control/Lens/TH.hs view
@@ -28,6 +28,7 @@   , makeClassy, makeClassyFor, makeClassy_   , makeFields   , makeFieldsNoPrefix+  , makeFieldsId   -- ** Prisms   , makePrisms   , makeClassyPrisms@@ -58,6 +59,7 @@   , classUnderscoreNoPrefixFields   , underscoreFields   , abbreviatedFields+  , classIdFields   -- ** LensRules configuration accessors   , lensField   , FieldNamer@@ -78,6 +80,7 @@   , classUnderscoreNoPrefixNamer   , underscoreNamer   , abbreviatedNamer+  , classIdNamer   ) where  import Prelude ()@@ -634,6 +637,19 @@       methodName = fieldUnprefixed   return (MethodName (mkName className) (mkName methodName)) +-- | Field rules for fields whose names are to be used verbatim, with no+-- prefixes, no underscores, no transformations of any kind.+classIdFields :: LensRules+classIdFields =+  defaultFieldRules & lensField .~ classIdNamer++-- | A 'FieldNamer' for 'classIdFields'.+classIdNamer :: FieldNamer+classIdNamer _ _ field = [MethodName (mkName className) (mkName fieldName)]+  where+  fieldName = nameBase field+  className = "Has" ++ overHead toUpper fieldName+ -- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @ -- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. -- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.@@ -743,6 +759,42 @@ -- @ makeFieldsNoPrefix :: Name -> DecsQ makeFieldsNoPrefix = makeFieldOptics classUnderscoreNoPrefixFields++-- | Generate overloaded field accessors, using exactly the same names as the+-- underlying fields. Intended for use with the @NoFieldSelectors@ and+-- @DuplicateRecordFields@ language extensions.+--+-- As an example:+--+-- @+-- data Foo a  = Foo { x :: 'Int', y :: a }+-- newtype Bar = Bar { x :: 'Char' }+-- makeFieldsId ''Foo+-- makeFieldsId ''Bar+-- @+--+-- will create classes+--+-- @+-- class HasX s a | s -> a where+--   x :: Lens' s a+-- class HasY s a | s -> a where+--   y :: Lens' s a+-- @+--+-- together with instances+--+-- @+-- instance HasX (Foo a) Int+-- instance HasY (Foo a) a where+-- instance HasX Bar Char where+-- @+--+-- @+-- makeFieldsId = 'makeLensesWith' 'classIdFields'+-- @+makeFieldsId :: Name -> DecsQ+makeFieldsId = makeFieldOptics classIdFields  defaultFieldRules :: LensRules defaultFieldRules = LensRules
src/Control/Lens/Traversal.hs view
@@ -162,7 +162,7 @@ import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable import Data.Tuple (swap)-import GHC.Magic (inline)+import GHC.Exts (inline)  -- $setup -- >>> :set -XNoOverloadedStrings -XFlexibleContexts
src/Control/Lens/Wrapped.hs view
@@ -150,6 +150,9 @@ import           Data.Set (Set) import           Data.Tagged import qualified Data.Vector as Vector+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import qualified Data.Vector.Primitive as Prim import           Data.Vector.Primitive (Prim) import qualified Data.Vector.Unboxed as Unboxed@@ -676,6 +679,14 @@   _Wrapped' = iso Storable.toList Storable.fromList   {-# INLINE _Wrapped' #-} +#if MIN_VERSION_vector(0,13,2)+instance (t ~ Vector.Vector a') => Rewrapped (VectorStrict.Vector a) t+instance Wrapped (VectorStrict.Vector a) where+  type Unwrapped (VectorStrict.Vector a) = [a]+  _Wrapped' = iso VectorStrict.toList VectorStrict.fromList+  {-# INLINE _Wrapped' #-}+#endif+ -- * semigroupoids  instance (t ~ WrappedApplicative f' a') => Rewrapped (WrappedApplicative f a) t@@ -873,7 +884,11 @@ #endif  getErrorCall :: ErrorCall -> String+#if MIN_VERSION_base(4,21,0)+getErrorCall (ErrorCall x) = x+#else getErrorCall (ErrorCallWithLocation x _) = x+#endif {-# INLINE getErrorCall #-}  getRecUpdError :: RecUpdError -> String
src/Control/Lens/Zoom.hs view
@@ -46,6 +46,9 @@ import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict+#if MIN_VERSION_mtl(2,3,0)+import Control.Monad.Trans.RWS.CPS as CPS+#endif import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe@@ -102,6 +105,9 @@ type instance Magnified ((->)b) = Const type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m+#if MIN_VERSION_mtl(2,3,0)+type instance Magnified (CPS.RWST a w s m) = EffectRWS w s m+#endif type instance Magnified (IdentityT m) = Magnified m  ------------------------------------------------------------------------------@@ -273,6 +279,12 @@ instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where   magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m)   {-# INLINE magnify #-}++#if MIN_VERSION_mtl(2,3,0)+instance (Monad m, Monoid w, MonadReader b (CPS.RWST b w s m)) => Magnify (CPS.RWST b w s m) (CPS.RWST a w s m) b a where+  magnify l m = CPS.rwsT $ getEffectRWS #. l (EffectRWS #. CPS.runRWST m)+  {-# INLINE magnify #-}+#endif  instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where   magnify l (IdentityT m) = IdentityT (magnify l m)
src/Control/Monad/Error/Lens.hs view
@@ -211,8 +211,8 @@ -- @'throwing' l ≡ 'reviews' l 'throwError'@ -- -- @--- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> a--- 'throwing' :: 'MonadError' e m => 'Iso'' e t   -> t -> a+-- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> m a+-- 'throwing' :: 'MonadError' e m => 'Iso'' e t   -> t -> m a -- @ throwing :: MonadError e m => AReview e t -> t -> m x throwing l = reviews l throwError
src/Data/Data/Lens.hs view
@@ -12,12 +12,6 @@ {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fno-full-laziness #-}-#if __GLASGOW_HASKELL__ >= 810--- Use -fbyte-code explicitly to ensure that -fobject-code isn't automatically--- implied on GHCi 8.10+ by the use of UnboxedTuples, as this breaks the--- doctests. See #874 for more details.-{-# OPTIONS_GHC -fbyte-code #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Data.Lens
src/Language/Haskell/TH/Lens.hs view
@@ -148,6 +148,12 @@   , _ForallC   , _GadtC   , _RecGadtC+#if MIN_VERSION_template_haskell(2,22,0)+  -- ** NamespaceSpecifier Prisms+  , _NoNamespaceSpecifier+  , _TypeNamespaceSpecifier+  , _DataNamespaceSpecifier+#endif   -- ** Overlap Prisms   ,_Overlappable   ,_Overlapping@@ -191,6 +197,12 @@ #if MIN_VERSION_template_haskell(2,19,0)   , _OpaqueP #endif+#if MIN_VERSION_template_haskell(2,22,0)+  , _SCCP+#endif+#if MIN_VERSION_template_haskell(2,24,0)+  , _SpecialiseEP+#endif   -- ** Inline Prisms   , _NoInline   , _Inline@@ -269,6 +281,14 @@   , _TypedBracketE   , _TypedSpliceE #endif+#if MIN_VERSION_template_haskell(2,22,0)+  , _TypeE+#endif+#if MIN_VERSION_template_haskell(2,23,0)+  , _ForallE+  , _ForallVisE+  , _ConstrainedE+#endif   -- ** Body Prisms   , _GuardedB   , _NormalB@@ -322,6 +342,13 @@   , _ListP   , _SigP   , _ViewP+#if MIN_VERSION_template_haskell(2,22,0)+  , _TypeP+  , _InvisP+#endif+#if MIN_VERSION_template_haskell(2,23,0)+  , _OrP+#endif   -- ** Type Prisms   , _ForallT   , _AppT@@ -934,6 +961,32 @@       remitter (InstanceD x y z w) = Just (x, y, z, w)       remitter _ = Nothing +#if MIN_VERSION_template_haskell(2,22,0)+_NoNamespaceSpecifier :: Prism' NamespaceSpecifier ()+_NoNamespaceSpecifier+  = prism' reviewer remitter+  where+      reviewer () = NoNamespaceSpecifier+      remitter NoNamespaceSpecifier = Just ()+      remitter _ = Nothing++_TypeNamespaceSpecifier :: Prism' NamespaceSpecifier ()+_TypeNamespaceSpecifier+  = prism' reviewer remitter+  where+      reviewer () = TypeNamespaceSpecifier+      remitter TypeNamespaceSpecifier = Just ()+      remitter _ = Nothing++_DataNamespaceSpecifier :: Prism' NamespaceSpecifier ()+_DataNamespaceSpecifier+  = prism' reviewer remitter+  where+      reviewer () = DataNamespaceSpecifier+      remitter DataNamespaceSpecifier = Just ()+      remitter _ = Nothing+#endif+ _Overlappable  :: Prism' Overlap  () _Overlappable  = prism' reviewer remitter   where@@ -978,6 +1031,20 @@       remitter (ForeignD x) = Just x       remitter _ = Nothing +-- |+-- @+-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'NamespaceSpecifier', 'Name') -- template-haskell-2.22++-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'Name')                     -- Earlier versions+-- @+#if MIN_VERSION_template_haskell(2,22,0)+_InfixD :: Prism' Dec (Fixity, NamespaceSpecifier, Name)+_InfixD+  = prism' reviewer remitter+  where+      reviewer (x, y, z) = InfixD x y z+      remitter (InfixD x y z) = Just (x, y, z)+      remitter _ = Nothing+#else _InfixD :: Prism' Dec (Fixity, Name) _InfixD   = prism' reviewer remitter@@ -985,6 +1052,7 @@       reviewer (x, y) = InfixD x y       remitter (InfixD x y) = Just (x, y)       remitter _ = Nothing+#endif  _PragmaD :: Prism' Dec Pragma _PragmaD@@ -1544,6 +1612,26 @@       remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,22,0)+_SCCP :: Prism' Pragma (Name, Maybe String)+_SCCP+  = prism' reviewer remitter+  where+      reviewer (x, y) = SCCP x y+      remitter (SCCP x y) = Just (x, y)+      remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,24,0)+_SpecialiseEP :: Prism' Pragma (Maybe [TyVarBndr ()], [RuleBndr], Exp, Maybe Inline, Phases)+_SpecialiseEP+  = prism' reviewer remitter+  where+    reviewer (x, y, z, w, u) = SpecialiseEP x y z w u+    remitter (SpecialiseEP x y z w u) = Just (x, y, z, w, u)+    remitter _ = Nothing+#endif+ _NoInline :: Prism' Inline () _NoInline   = prism' reviewer remitter@@ -2060,6 +2148,42 @@       remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,22,0)+_TypeE :: Prism' Exp Type+_TypeE+  = prism' reviewer remitter+  where+      reviewer = TypeE+      remitter (TypeE x) = Just x+      remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,23,0)+_ForallE :: Prism' Exp ([TyVarBndr Specificity], Exp)+_ForallE+  = prism' reviewer remitter+  where+      reviewer (x, y) = ForallE x y+      remitter (ForallE x y) = Just (x, y)+      remitter _ = Nothing++_ForallVisE :: Prism' Exp ([TyVarBndr ()], Exp)+_ForallVisE+  = prism' reviewer remitter+  where+      reviewer (x, y) = ForallVisE x y+      remitter (ForallVisE x y) = Just (x, y)+      remitter _ = Nothing++_ConstrainedE :: Prism' Exp ([Exp], Exp)+_ConstrainedE+  = prism' reviewer remitter+  where+      reviewer (x, y) = ConstrainedE x y+      remitter (ConstrainedE x y) = Just (x, y)+      remitter _ = Nothing+#endif+ _GuardedB :: Prism' Body [(Guard, Exp)] _GuardedB   = prism' reviewer remitter@@ -2408,6 +2532,34 @@       reviewer (x, y) = ViewP x y       remitter (ViewP x y) = Just (x, y)       remitter _ = Nothing++#if MIN_VERSION_template_haskell(2,22,0)+_TypeP :: Prism' Pat Type+_TypeP+  = prism' reviewer remitter+  where+      reviewer = TypeP+      remitter (TypeP x) = Just x+      remitter _ = Nothing++_InvisP :: Prism' Pat Type+_InvisP+  = prism' reviewer remitter+  where+      reviewer = InvisP+      remitter (InvisP x) = Just x+      remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,23,0)+_OrP :: Prism' Pat (NonEmpty Pat)+_OrP+  = prism' reviewer remitter+  where+      reviewer = OrP+      remitter (OrP x) = Just x+      remitter _ = Nothing+#endif  _ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT
+ tests/T1024.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Test 'makeFieldsId', which requires NoFieldSelectors and+-- DuplicateRecordFields. This test consequently only works on GHC >= 9.2.+module T1024 where++import Control.Lens++data Taco = Taco+  { hardShell :: Bool+  , sauce :: Int+  , filling :: String+  }+data Burrito = Burrito+  { sauce :: Int+  , filling :: String+  }+makeFieldsId ''Taco+makeFieldsId ''Burrito++checkTacoHardShell :: Lens' Taco Bool+checkTacoHardShell = hardShell++checkBurritoFilling :: Lens' Burrito String+checkBurritoFilling = filling
tests/hunit.hs view
@@ -33,9 +33,8 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif-import Test.Framework.Providers.HUnit-import Test.Framework-import Test.HUnit hiding (test)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)   data Point =@@ -231,16 +230,96 @@     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]))+  (trig & points <<<>~ [ origin ])     @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] })  case_append_to_state_record_field_and_access_old_value = do   runState test trig @?= (_points trig, trig')   where-    test = points <<%= (<>[origin])+    test = points <<<>= [ origin ]     trig' = trig { _points = (trig & _points) <> [ origin ] } +case_cons_to_record_field_and_access_old_value =+  (trig & points <<<|~ origin)+    @?= (_points trig, trig { _points = origin : (trig & _points) })++case_cons_to_state_record_field_and_access_old_value =+  runState test trig @?= (_points trig, trig')+  where+    test = points <<<|= origin+    trig' = trig { _points = origin : (trig & _points) }++case_snoc_to_record_field_and_access_old_value =+  (trig & points <<|>~ origin)+    @?= (_points trig, trig { _points = (trig & _points) `snoc` origin })++case_snoc_to_state_record_field_and_access_old_value =+  runState test trig @?= (_points trig, trig')+  where+    test = points <<|>= origin+    trig' = trig { _points = (trig & _points) `snoc` origin }+ case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin"  case_read_maybe_state_map_entry =@@ -300,46 +379,61 @@     @?= [Nothing, Just 1, Just 2, Nothing]  main :: IO ()-main = defaultMain-  [ testGroup "Main"-    [ testCase "read record field" case_read_record_field-    , testCase "read state record field" case_read_state_record_field-    , testCase "read record field and apply function" case_read_record_field_and_apply_function-    , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function-    , testCase "write record field" case_write_record_field-    , testCase "write state record field" case_write_state_record_field-    , testCase "write record field and access new value" case_write_record_field_and_access_new_value-    , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value-    , testCase "write record field and access old value" case_write_record_field_and_access_old_value-    , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value-    , testCase "modify record field" case_modify_record_field-    , testCase "modify state record field" case_modify_state_record_field-    , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value-    , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value-    , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value-    , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value-    , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result-    , testCase "increment record field" case_increment_record_field-    , 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 "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-    , 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-    , testCase "read maybe state map entry" case_read_maybe_state_map_entry-    , testCase "read map entry" case_read_map_entry-    , testCase "read state map entry" case_read_state_map_entry-    , testCase "modify map entry" case_modify_map_entry-    , testCase "insert maybe map entry" case_insert_maybe_map_entry-    , testCase "delete maybe map entry" case_delete_maybe_map_entry-    , testCase "read list entry" case_read_list_entry-    , testCase "write list entry" case_write_list_entry-    , testCase "write through list entry" case_write_through_list_entry-    , testCase "correct indexing strict text" case_correct_indexing_strict_text-    , testCase "correct indexing lazy text" case_correct_indexing_lazy_text-    , testCase "correct indexing strict bytestring" case_correct_indexing_strict_bytestring-    , testCase "correct indexing lazy bytestring" case_correct_indexing_lazy_bytestring-    ]+main = defaultMain $+  testGroup "Main"+  [ testCase "read record field" case_read_record_field+  , testCase "read state record field" case_read_state_record_field+  , testCase "read record field and apply function" case_read_record_field_and_apply_function+  , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function+  , testCase "write record field" case_write_record_field+  , testCase "write state record field" case_write_state_record_field+  , testCase "write record field and access new value" case_write_record_field_and_access_new_value+  , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value+  , testCase "write record field and access old value" case_write_record_field_and_access_old_value+  , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value+  , testCase "modify record field" case_modify_record_field+  , testCase "modify state record field" case_modify_state_record_field+  , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value+  , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value+  , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value+  , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value+  , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result+  , testCase "increment record field" case_increment_record_field+  , 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 "cons to record field and access old value" case_cons_to_record_field_and_access_old_value+  , testCase "cons to state record field and access old value" case_cons_to_state_record_field_and_access_old_value+  , testCase "snoc to record field and access old value" case_snoc_to_record_field_and_access_old_value+  , testCase "snoc to state record field and access old value" case_snoc_to_state_record_field_and_access_old_value+  , testCase "read maybe map entry" case_read_maybe_map_entry+  , testCase "read maybe state map entry" case_read_maybe_state_map_entry+  , testCase "read map entry" case_read_map_entry+  , testCase "read state map entry" case_read_state_map_entry+  , testCase "modify map entry" case_modify_map_entry+  , testCase "insert maybe map entry" case_insert_maybe_map_entry+  , testCase "delete maybe map entry" case_delete_maybe_map_entry+  , testCase "read list entry" case_read_list_entry+  , testCase "write list entry" case_write_list_entry+  , testCase "write through list entry" case_write_through_list_entry+  , testCase "correct indexing strict text" case_correct_indexing_strict_text+  , testCase "correct indexing lazy text" case_correct_indexing_lazy_text+  , testCase "correct indexing strict bytestring" case_correct_indexing_strict_bytestring+  , testCase "correct indexing lazy bytestring" case_correct_indexing_lazy_bytestring   ]
tests/properties.hs view
@@ -26,8 +26,8 @@  import Control.Lens import Test.QuickCheck-import Test.Framework-import Test.Framework.Providers.QuickCheck2+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty) import Data.Char (isAlphaNum, isAscii, toUpper) import qualified Data.Text.Strict.Lens as Text import GHC.Exts (Constraint)@@ -129,32 +129,31 @@   main :: IO ()-main = defaultMain-  [ testGroup "Main"-    [ testProperty "1" prop_1-    , testProperty "2" prop_2-    , testProperty "3" prop_3-    , testProperty "4" prop_4-    , testProperty "5" prop_5-    , testProperty "6" prop_6-    , testProperty "7" prop_7-    , testProperty "8" prop_8-    , testProperty "9" prop_9-    , testProperty "10" prop_10-    , testProperty "2 2" prop_2_2-    , testProperty "mapped" prop_mapped-    , testProperty "mapped mapped" prop_mapped_mapped-    , testProperty "both" prop_both-    , testProperty "traverseLeft" prop_traverseLeft-    , testProperty "traverseRight" prop_traverseRight-    , testProperty "simple" prop_simple-    , testProperty " Left" prop__Left-    , testProperty " Right" prop__Right-    , testProperty " Just" prop__Just-    , testProperty "prefixed" prop_prefixed-    , testProperty "text" prop_text-    , testProperty "base show" prop_base_show-    , testProperty "base read" prop_base_read-    , testProperty "base readFail" prop_base_readFail-    ]+main = defaultMain $+  testGroup "Main"+  [ testProperty "1" prop_1+  , testProperty "2" prop_2+  , testProperty "3" prop_3+  , testProperty "4" prop_4+  , testProperty "5" prop_5+  , testProperty "6" prop_6+  , testProperty "7" prop_7+  , testProperty "8" prop_8+  , testProperty "9" prop_9+  , testProperty "10" prop_10+  , testProperty "2 2" prop_2_2+  , testProperty "mapped" prop_mapped+  , testProperty "mapped mapped" prop_mapped_mapped+  , testProperty "both" prop_both+  , testProperty "traverseLeft" prop_traverseLeft+  , testProperty "traverseRight" prop_traverseRight+  , testProperty "simple" prop_simple+  , testProperty " Left" prop__Left+  , testProperty " Right" prop__Right+  , testProperty " Just" prop__Just+  , testProperty "prefixed" prop_prefixed+  , testProperty "text" prop_text+  , testProperty "base show" prop_base_show+  , testProperty "base read" prop_base_read+  , testProperty "base readFail" prop_base_readFail   ]