lens 3.6.0.4 → 3.7
raw patch · 65 files changed
+3451/−1561 lines, 65 filesdep +generic-derivingdep +simple-reflectdep ~basedep ~splitdep ~vector
Dependencies added: generic-deriving, simple-reflect
Dependency ranges changed: base, split, vector
Files
- .travis.yml +15/−10
- CHANGELOG.markdown +44/−10
- README.markdown +18/−28
- benchmarks/plated.hs +4/−0
- lens.cabal +59/−20
- src/Control/Exception/Lens.hs +4/−2
- src/Control/Lens.hs +12/−13
- src/Control/Lens/Action.hs +2/−2
- src/Control/Lens/Classes.hs +88/−19
- src/Control/Lens/Combinators.hs +3/−2
- src/Control/Lens/Fold.hs +165/−30
- src/Control/Lens/Getter.hs +227/−41
- src/Control/Lens/Indexed.hs +30/−54
- src/Control/Lens/IndexedFold.hs +44/−26
- src/Control/Lens/IndexedGetter.hs +42/−3
- src/Control/Lens/IndexedLens.hs +32/−58
- src/Control/Lens/IndexedSetter.hs +9/−7
- src/Control/Lens/IndexedTraversal.hs +113/−43
- src/Control/Lens/Internal.hs +102/−7
- src/Control/Lens/Internal/Combinators.hs +63/−55
- src/Control/Lens/Internal/Zipper.hs +300/−198
- src/Control/Lens/Iso.hs +140/−116
- src/Control/Lens/Isomorphic.hs +0/−87
- src/Control/Lens/Loupe.hs +23/−2
- src/Control/Lens/Plated.hs +22/−10
- src/Control/Lens/Prism.hs +350/−0
- src/Control/Lens/Projection.hs +0/−74
- src/Control/Lens/Representable.hs +6/−7
- src/Control/Lens/Setter.hs +251/−56
- src/Control/Lens/Simple.hs +1/−0
- src/Control/Lens/TH.hs +43/−57
- src/Control/Lens/Traversal.hs +54/−55
- src/Control/Lens/Tuple.hs +45/−45
- src/Control/Lens/Type.hs +100/−20
- src/Control/Lens/WithIndex.hs +39/−25
- src/Control/Lens/Wrapped.hs +434/−0
- src/Control/Lens/Zipper.hs +14/−9
- src/Control/Lens/Zoom.hs +35/−7
- src/Control/Parallel/Strategies/Lens.hs +1/−1
- src/Data/Array/Lens.hs +2/−2
- src/Data/Bits/Lens.hs +2/−2
- src/Data/ByteString/Lazy/Lens.hs +3/−2
- src/Data/ByteString/Lens.hs +3/−2
- src/Data/ByteString/Strict/Lens.hs +3/−2
- src/Data/Complex/Lens.hs +94/−31
- src/Data/Data/Lens.hs +86/−73
- src/Data/Dynamic/Lens.hs +3/−5
- src/Data/HashSet/Lens.hs +1/−1
- src/Data/List/Lens.hs +70/−17
- src/Data/List/Split/Lens.hs +5/−6
- src/Data/Monoid/Lens.hs +0/−133
- src/Data/Sequence/Lens.hs +125/−25
- src/Data/Set/Lens.hs +2/−2
- src/Data/Text/Lazy/Lens.hs +5/−4
- src/Data/Text/Lens.hs +4/−3
- src/Data/Text/Strict/Lens.hs +4/−3
- src/Data/Tree/Lens.hs +5/−6
- src/Data/Typeable/Lens.hs +4/−4
- src/Data/Vector/Generic/Lens.hs +9/−10
- src/Data/Vector/Lens.hs +12/−13
- src/GHC/Generics/Lens.hs +15/−3
- src/Language/Haskell/TH/Lens.hs +3/−3
- tests/hunit.hs +1/−1
- tests/properties.hs +48/−6
- tests/templates.hs +8/−3
.travis.yml view
@@ -1,19 +1,18 @@ language: haskell before_install:- # Uncomment the next 3 lines whenever hackage is down.- # - mkdir -p ~/.cabal- # - cp config ~/.cabal/config- # - cabal update+ # Uncomment whenever hackage is down.+ # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update - # adding the hunit test suite causes us to have to reinstall regex-posix and regex-base- - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstall+ # Try installing some of the build-deps with apt-get for speed.+ - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode+ install:- # we have to configure rather than install in order to get benchmarks- - cabal configure --enable-tests --enable-benchmarks -fdump-splices+ - cabal configure $mode - cabal build+ script:- - cabal test --show-details=always- - cabal bench+ - $script+ notifications: irc: channels:@@ -21,3 +20,9 @@ skip_join: true template: - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++env:+ - mode="--enable-tests" script="cabal test"+ # - mode="--enable-tests -fsafe" script="cabal test"+ # - mode="--enable-tests -fdump-splices" script="cabal test --show-details=always"+ # - mode="--enable-benchmarks -fdump-splices" script="cabal bench"
CHANGELOG.markdown view
@@ -1,3 +1,37 @@+[3.7](https://github.com/ekmett/lens/issues?milestone=11&page=1&state=closed)+-----+* Renamed `Projection` to `Prism`.+* Implemented a complete redesign of the way `Iso` and `Prism` are handled internally. Any `Iso` can now be used as a `Prism`.+* The `isos` combinator is no longer required. `iso` can now be used to construct an `Iso`.+* Changes to the signature of `from` and `under` were necessitated by the new design.+* Added `Control.Lens.Wrapped` providing a canonical isomorphism for newtypes.+* Repurposed `ala` to be closer to the original design in `newtype`, but added `au` and `alaf`.+* Added `_magnitude`, `_phase` and `_conjugate` to `Data.Complex.Lens`. Renamed other lenses for consistency: `_realPart`, `_imagPart`, `_polar`.+* Promoted `_left` and `_right` to prisms and moved them to `Control.Lens.Prism`.+* Generalized `view` and `views` to subsume the old functionality of `peruse` and `peruses`.+* Generalized `review` and `reviews` to both return a `MonadReader` and to work on a `Projection`.+* Added `view'`/`views'` and `use'`/`uses'` for `Simple` access to the environment/state.+* Added `set'`, a `Simple` version of `set`.+* Added `reuse` : `use` :: `review` : `view` and `reuses` : `uses` :: `reviews` : `views` for working a `Projection` from the current `MonadState`.+* Removed many isomorphisms for various newtypes. `_const`, `identity`, `_sum`, etc. Use `wrapping Const`, `wrapping Identity`, etc.+* Removed `Data.Monoid.Lens` now that its newtypes are instances of `Wrapped`, exporting the (`<>=`)-variants from `Control.Lens.*`.+* Renamed `via` to `cloneIso` for consistency.+* Moved `Indexed(..)` to `Control.Lens.Classes`.+* Renamed `index` to `indexing` to reduce conflicts with third-party libraries.+* Added `curried` and `uncurried` to `Control.Lens.Iso`.+* Added `Strict(strict)` for ad hoc overloading of conversions between strict and lazy variants of `ByteString` and `Text`.+* Bug fixes for `tugTo` and `jerkTo`.+* These no longer traverse in the wrong direction: `scanl1Of`, `scanr1Of`, `mapAccumLOf`, and `mapAccumROf`.+* Added `anon` to `Control.Lens.Iso`.+* Generalized the types of the `Control.Lens.Zipper` combinators to work with other MonadPlus instances.+* Added `withins` to `Control.Lens.Zipper` now that they can work better with [].+* Added `singular` and `unsafeSingular` to `Control.Lens.Traversal` to assert a `Traversal` is a `Lens`, a `Fold` is a `Getter` or a `MonadicFold` is an `Action`.+* Generalized `sequenceAOf_`'s type to match `sequenceA_`.+* Renamed `up`/`down`/`left`/`right` to `upward`/`downward`/`leftward`/`rightward` to reduce conflicts -- in particular with `Control.Arrow`.+* Readded `leftmost` and `rightmost` due to the verbosity of `farthest leftward`/`farthest rightward`.+* Added `preview`/`previews`/`firstOf` and deprecated `headOf`.+* Added `iview`/`iviews`/`iuse`/`iuses` to `Control.Lens.IndexedGetter`.+ 3.6.0.4 [maintenance release] ------- * Added support for `test-framework` 0.8@@ -15,8 +49,8 @@ ------- * Added explicit dependency on containers and unordered-containers to the doctest suite -3.6------+[3.6](https://github.com/ekmett/lens/issues?milestone=9&state=closed)+--- * Added `upon` (along with variants of it) to `Data.Data.Lens`, which can be used to generate a `Traversal` from a field accessor or any function that returns, unmodified, a single field that would be visited by `template`. * Added some missing `examples/` files to the distribution.@@ -42,7 +76,7 @@ ----- * Improved SafeHaskell inference. -3.5+[3.5](https://github.com/ekmett/lens/issues?milestone=8&state=closed) --- * Fixed a potential SafeHaskell issue where a user could use `undefined` to derive `unsafeCoerce`. You now have to import an explicitly Unsafe module and create an instance of `Trustworthy` for your type to cause this behavior, so if you do, its on your head, not mine. :)@@ -50,7 +84,7 @@ * Moved a lot of internals around. Most notably, `Gettable`, `Settable` and `Effective` have moved to `Control.Lens.Classes`. * Exposed `partsOf'` and `unsafePartsOf'` in `Control.Lens.Traversal` to reduce reliance on `BazaarT` in `Control.Lens.Zipper` -3.4+[3.4](https://github.com/ekmett/lens/issues?milestone=7&state=closed) --- * Renamed `(%)` to `(&)` and `(^%)` to `(^&)`. This avoids the conflict with `Data.Ratio`, which was our highest priority conflict with a third party library. * Switched to a more liberal type for `ignored`@@ -130,13 +164,13 @@ ----- * Added `Control.Lens.Type.simple`. -3.0+[3.0](https://github.com/ekmett/lens/issues?milestone=6&state=closed) --- * Added `Control.Lens.Zipper`. * Added `<<~`, a version of `<~` that supports chaining assignment. * Added `:->`, `:=>`, and `:<->` as type operator aliases for `Simple Lens`, `Simple Traversal`, and `Simple Iso` respectively. -2.9+[2.9](https://github.com/ekmett/lens/issues?milestone=5&state=closed) --- * Added `<<%~`, `<<.~`, `<<%=` and `<<.=` for accessing the old values targeted by a `Lens` (or a summary of those targeted by a `Traversal`) * Renamed `|>` to `%`, as `%~` is the lensed version of `%`, and moved it to `Control.Lens.Getter` along with a version `^%` with tighter@@ -151,7 +185,7 @@ it will default to the old behavior. * Added `performs` to `Control.Lens.Action` to mirror `views` in `Control.Lens.Getter`. -2.8+[2.8](https://github.com/ekmett/lens/issues?milestone=4&state=closed) --- * Restored compatibility with GHC 7.2. This required a major version bump due to making some MPTC-based default signatures conditional. @@ -159,7 +193,7 @@ ------- * Added the missing `Control.Lens.Combinators` to exported-modules! Its absence was causing it not to be included on hackage. -2.7+[2.7](https://github.com/ekmett/lens/issues?milestone=3&state=closed) --- * Generalized the signature of `Getting`, `Acting` and `IndexedGetting` to help out with the common user code scenario of needing to read and then write to change types.@@ -176,7 +210,7 @@ ----- * Fixed bugs in `Traversal` code-generation. -2.6+[2.6](https://github.com/ekmett/lens/issues?milestone=2&state=closed) --- * Added build option `-f-inlining` to facilitate building with the various TH 2.8 versions used by GHC 7.6 and HEAD. * Added build option `-f-template-haskell` for testing without template haskell. (Users should be able to assume TH is enabled; use this only for testing!)@@ -186,7 +220,7 @@ * Added `assign` as an alias for `(.=)` in `Control.Lens.Setter`. * Added `~:`, `=:`, `<~:` and `<=:` to `Data.List.Lens` -2.5+[2.5](https://github.com/ekmett/lens/issues?milestone=1&state=closed) --- * Added `Control.Lens.Plated`, a port of Neil Mitchell's `uniplate` that can be used on any `Traversal`. * Added `Data.Data.Lens` with smart traversals that know how to avoid traversing parts of a structure that can't contain a given type.
README.markdown view
@@ -5,9 +5,9 @@ This package provides families of [lenses](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Type.hs), [isomorphisms](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Iso.hs), [folds](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Fold.hs), [traversals](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Traversal.hs), [getters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Getter.hs) and [setters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Setter.hs). -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).+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) or [hackage](http://hackage.haskell.org/package/lens).+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. Field Guide -----------@@ -86,8 +86,6 @@ You can let the library automatically derive lenses for fields of your data type ```haskell-import Control.Lens- data Foo a = Foo { _bar :: Int, _baz :: Int, _quux :: a } makeLenses ''Foo ```@@ -332,6 +330,13 @@ <td>Logically and target(s)</td> </tr> <tr>+ <td><a href="http://ekmett.github.com/lens/Control-Lens-Setter.html#v:-60--62--126-"><code><>~</code></a></td>+ <td><a href="http://ekmett.github.com/lens/Control-Lens-Type.html#v:-60--60--62--126-"><code><<>~</code></td>+ <td><a href="http://ekmett.github.com/lens/Control-Lens-Setter.html#v:-60--62--61-"><code><>=</code></a></td>+ <td><a href="http://ekmett.github.com/lens/Control-Lens-Type.html#v:-60--60--62--61-"><code><<>=</code></td>+ <td><code>mappend</code> to the target monoidal value(s)</td>+</tr>+<tr> <td><a href="http://ekmett.github.com/lens/Control-Lens-Fold.html#v:headOf"><code>headOf</code>,<a href="http://ekmett.github.com/lens/Control-Lens-Fold.html#v:-94--63-"><code>^?</code></a></td> <td/><td/><td/> <td>Return <code>Just</code> the first target or <code>Nothing</code></td>@@ -365,35 +370,19 @@ </tr> <tr><th colspan=5><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html">Data.Bits.Lens</a></th></tr> <tr>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-124--126-"><code>|~</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--124--126-"><code><|~</code></td>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-124--61-"><code>|=</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--124--61-"><code><|=</code></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-124--126-"><code>.|.~</code></a></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--124--126-"><code><.|.~</code></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-124--61-"><code>.|.=</code></a></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--124--61-"><code><.|.=</code></td> <td>Bitwise or target(s)</td> </tr> <tr>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-38--126-"><code>&~</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--38--126-"><code><&~</code></td>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-38--61-"><code>&=</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--38--61-"><code><&=</code></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-38--126-"><code>.&.~</code></a></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--38--126-"><code><.&.~</code></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-38--61-"><code>.&.=</code></a></td>+ <td><a href="http://ekmett.github.com/lens/Data-Bits-Lens.html#v:-60--38--61-"><code><.&.=</code></td> <td>Bitwise and target(s)</td> </tr>-<tr><th colspan=5><a href="http://ekmett.github.com/lens/Data-Monoid-Lens.html">Data.List.Lens</a></th></tr>-<tr>- <td><a href="http://ekmett.github.com/lens/Data-List-Lens.html#v:-43--43--126-"><code>++~</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-List-Lens.html#v:-60--43--43--126-"><code><++~</code></td>- <td><a href="http://ekmett.github.com/lens/Data-List-Lens.html#v:-43--43--61-"><code>++=</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-List-Lens.html#v:-60--43--43--61-"><code><++=</code></td>- <td>Append to target list(s)</td>-</tr>-<tr><th colspan=5><a href="http://ekmett.github.com/lens/Data-Monoid-Lens.html">Data.Monoid.Lens</a></th></tr>-<tr>- <td><a href="http://ekmett.github.com/lens/Data-Monoid-Lens.html#v:-60--62--126-"><code><>~</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-Monoid-Lens.html#v:-60--60--62--126-"><code><<>~</code></td>- <td><a href="http://ekmett.github.com/lens/Data-Monoid-Lens.html#v:-60--62--61-"><code><>=</code></a></td>- <td><a href="http://ekmett.github.com/lens/Data-Monoid-Lens.html#v:-60--60--62--61-"><code><<>=</code></td>- <td><code>mappend</code> to the target monoidal value(s)</td>-</tr> <tr><th colspan=5><a href="http://ekmett.github.com/lens/System-FilePath-Lens.html">System.FilePath.Lens</a></th></tr> <tr> <td><a href="http://ekmett.github.com/lens/System-FilePath-Lens.html#v:-60--47--62--126-"><code></>~</code></a></td>@@ -411,6 +400,7 @@ </tr> </tbody> </table>+ Contact Information -------------------
benchmarks/plated.hs view
@@ -14,7 +14,11 @@ import Data.Generics.Uniplate.Direct ((|*)) import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly #endif+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics+#else+import Generics.Deriving+#endif import GHC.Generics.Lens as Generic data Expr = Val !Int
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses-version: 3.6.0.4+version: 3.7 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -37,10 +37,10 @@ . The core of this hierarchy looks like: .- <<http://i.imgur.com/I0uXl.png>>+ <<http://i.imgur.com/FgfVW.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 links to above it.+ use any element of the hierarchy as any type it linked to above it. . The result is their lowest upper bound in the hierarchy (or an error if that bound doesn't exist). .@@ -82,7 +82,7 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). build-type: Simple-tested-with: GHC == 7.4.1, GHC == 7.6.1+tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1 extra-source-files: .travis.yml .ghci@@ -138,9 +138,28 @@ default: False manual: True +-- You can disable the hunit test suite with -f-test-hunit+flag test-hunit+ default: True+ manual: True++flag test-properties+ default: True+ manual: True++-- Disallow unsafeCoerce+flag safe+ default: False+ manual: True++-- Assert that we are trustworthy when we can+flag trustworthy+ default: True+ manual: False+ library build-depends:- base >= 4.4 && < 5,+ base >= 4.3 && < 5, bytestring >= 0.9.1.10 && < 0.11, comonad == 3.0.*, comonad-transformers == 3.0.*,@@ -172,10 +191,9 @@ Control.Lens.Internal Control.Lens.Internal.Zipper Control.Lens.Iso- Control.Lens.Isomorphic Control.Lens.Loupe Control.Lens.Plated- Control.Lens.Projection+ Control.Lens.Prism Control.Lens.Representable Control.Lens.Setter Control.Lens.Simple@@ -183,6 +201,7 @@ Control.Lens.Tuple Control.Lens.Type Control.Lens.WithIndex+ Control.Lens.Wrapped Control.Lens.Zipper Control.Lens.Zoom Data.Bits.Lens@@ -196,7 +215,6 @@ Data.IntSet.Lens Data.List.Lens Data.List.Split.Lens- Data.Monoid.Lens Data.Sequence.Lens Data.Set.Lens Data.Text.Lens@@ -206,6 +224,7 @@ Data.Typeable.Lens Data.Vector.Lens Data.Vector.Generic.Lens+ GHC.Generics.Lens other-modules: Control.Lens.Internal.Combinators@@ -214,8 +233,17 @@ build-depends: template-haskell >= 2.4 && < 2.9 exposed-modules: Control.Lens.TH Language.Haskell.TH.Lens else- cpp-options: -DDISABLE_TEMPLATE_HASKELL+ cpp-options: -DDISABLE_TEMPLATE_HASKELL=1 + if flag(safe)+ cpp-options: -DSAFE=1++ if flag(trustworthy) && impl(ghc>=7.2)+ cpp-options: -DTRUSTWORTHY=1++ if impl(ghc<7.4)+ ghc-options: -fno-spec-constr-count+ -- platform build-depends: array >= 0.3.0.2 && < 0.5 exposed-modules: Data.Array.Lens@@ -228,15 +256,17 @@ if impl(ghc>=7.6.0.20120810) if flag(old-inline-pragmas)- cpp-options: -DOLD_INLINE_PRAGMAS+ cpp-options: -DOLD_INLINE_PRAGMAS=1 if !flag(inlining)- cpp-options: -DOMIT_INLINING+ cpp-options: -DOMIT_INLINING=1 - if impl(ghc>=7.4)+ if impl(ghc>=7.2) other-extensions: Trustworthy build-depends: ghc-prim- exposed-modules: GHC.Generics.Lens+ cpp-options: -DDEFAULT_SIGNATURES=1+ else+ build-depends: generic-deriving ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields hs-source-dirs: src@@ -266,6 +296,8 @@ transformers ghc-options: -w -threaded hs-source-dirs: tests+ if !flag(test-properties)+ buildable: False test-suite hunit type: exitcode-stdio-1.0@@ -276,11 +308,13 @@ HUnit == 1.2.*, lens, mtl,- test-framework >= 0.6 && < 0.9,+ test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4,- test-framework-th >= 0.2 && < 0.4+ test-framework-th >= 0.2 && < 0.4 ghc-options: -w -threaded hs-source-dirs: tests+ if !flag(test-hunit)+ buildable: False -- Verify the results of the examples test-suite doctests@@ -295,8 +329,11 @@ filepath, mtl, parallel,+ simple-reflect >= 0.3.1 && < 0.4,+ split, text,- unordered-containers+ unordered-containers,+ vector ghc-options: -Wall -threaded if impl(ghc<7.6.1) ghc-options: -Werror@@ -311,16 +348,19 @@ comonad, criterion, deepseq,- ghc-prim, lens, transformers+ if impl(ghc>=7.2)+ build-depends: ghc-prim+ else+ build-depends: generic-deriving ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks if flag(benchmark-uniplate) build-depends: uniplate >= 1.6.7 && < 1.7 cpp-options: -DBENCHMARK_UNIPLATE --- Basic benchmarks for the uniplate-style combinators+-- Benchmarking alongside variants benchmark alongside type: exitcode-stdio-1.0 main-is: alongside.hs@@ -330,13 +370,12 @@ comonads-fd, criterion, deepseq,- ghc-prim, lens, transformers ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks --- Basic benchmarks for the uniplate-style combinators+-- Benchmarking unsafe implementation strategies benchmark unsafe type: exitcode-stdio-1.0 main-is: unsafe.hs
src/Control/Exception/Lens.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens@@ -24,6 +26,6 @@ -- exception :: ('Applicative' f, 'Exception' a, 'Exception' b) -- => (a -> f b) -> 'SomeException' -> f 'SomeException' -- @-exception :: (Exception a, Exception b) => Projection SomeException SomeException a b-exception = projection SomeException fromException+exception :: Exception a => Simple Prism SomeException a+exception = prism toException $ \ e -> maybe (Left e) Right $ fromException e {-# INLINE exception #-}
src/Control/Lens.hs view
@@ -3,9 +3,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE FlexibleContexts #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens@@ -44,32 +41,33 @@ -- -- <http://github.com/ekmett/lens/wiki> ----- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-3.6.png>>+-- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-3.7.png>> ---------------------------------------------------------------------------- module Control.Lens- ( module Control.Lens.Type- , module Control.Lens.Traversal- , module Control.Lens.Getter- , module Control.Lens.Setter- , module Control.Lens.Action+ ( module Control.Lens.Action , module Control.Lens.Combinators , module Control.Lens.Fold- , module Control.Lens.Iso+ , module Control.Lens.Getter , module Control.Lens.Indexed , module Control.Lens.IndexedFold , module Control.Lens.IndexedGetter , module Control.Lens.IndexedLens- , module Control.Lens.IndexedTraversal , module Control.Lens.IndexedSetter+ , module Control.Lens.IndexedTraversal+ , module Control.Lens.Iso , module Control.Lens.Loupe , module Control.Lens.Plated- , module Control.Lens.Projection+ , module Control.Lens.Prism , module Control.Lens.Representable+ , module Control.Lens.Setter #ifndef DISABLE_TEMPLATE_HASKELL , module Control.Lens.TH #endif+ , module Control.Lens.Traversal , module Control.Lens.Tuple+ , module Control.Lens.Type , module Control.Lens.WithIndex+ , module Control.Lens.Wrapped , module Control.Lens.Zipper , module Control.Lens.Zoom ) where@@ -87,7 +85,7 @@ import Control.Lens.Iso import Control.Lens.Loupe import Control.Lens.Plated-import Control.Lens.Projection+import Control.Lens.Prism import Control.Lens.Representable import Control.Lens.Setter #ifndef DISABLE_TEMPLATE_HASKELL@@ -97,5 +95,6 @@ import Control.Lens.Tuple import Control.Lens.Type import Control.Lens.WithIndex+import Control.Lens.Wrapped import Control.Lens.Zipper import Control.Lens.Zoom
src/Control/Lens/Action.hs view
@@ -22,7 +22,7 @@ , liftAct , (^!) - -- * Folds with Effecs+ -- * Folds with Effects , MonadicFold -- * Implementation Details@@ -87,7 +87,7 @@ -- | A self-running 'Action', analogous to 'Control.Monad.join'. ----- @'acts' = 'act' 'id'@+-- @'acts' ≡ 'act' 'id'@ -- -- >>> (1,"hello")^!_2.acts.to succ -- "ifmmp"
src/Control/Lens/Classes.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#if defined(TRUSTWORTHY) && !defined(SAFE) {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -24,20 +26,35 @@ , noEffect -- * Actions , Effective(..)- , ineffective -- * Setters , Settable(..)+ -- * Isomorphisms+ , Isomorphic(..)+ -- * Prisms+ , Prismatic(..)+ -- * Indexable+ , Indexable(..) ) where import Control.Applicative-import Control.Applicative.Backwards-import Control.Lens.Isomorphic+import Control.Applicative.Backwards (Backwards(..))+import Control.Category import Control.Monad (liftM)-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Monoid-import Unsafe.Coerce+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid (Dual(..))+import Prelude hiding ((.),id)+#ifndef SAFE+import Unsafe.Coerce (unsafeCoerce)+#endif +#ifndef SAFE+#define UNSAFELY(x) unsafeCoerce+#else+#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))+#endif++ ------------------------------------------------------------------------------- -- Gettables & Accessors -------------------------------------------------------------------------------@@ -81,15 +98,12 @@ -- -- That said, the monad is possibly rather unrelated to any 'Applicative' structure. class (Monad m, Gettable f) => Effective m r f | f -> m r where- effective :: Isomorphic k => k (m r) (f a)---- | A convenient antonym that is used internally.-ineffective :: Effective m r f => Isomorphic k => k (f a) (m r)-ineffective = from effective-{-# INLINE ineffective #-}+ effective :: m r -> f a+ ineffective :: f a -> m r instance Effective m r f => Effective m (Dual r) (Backwards f) where- effective = isomorphic (Backwards . effective . liftM getDual) (liftM Dual . ineffective . forwards)+ effective = Backwards . effective . liftM getDual+ ineffective = liftM Dual . ineffective . forwards ----------------------------------------------------------------------------- -- Settable@@ -100,17 +114,17 @@ untainted :: f a -> a untainted# :: (a -> f b) -> a -> b- untainted# f = untainted . f+ untainted# g = g `seq` \x -> untainted (g x) tainted# :: (a -> b) -> a -> f b- tainted# f = pure . f+ tainted# g = g `seq` \x -> pure (g x) -- | so you can pass our a 'Control.Lens.Setter.Setter' into combinators from other lens libraries instance Settable Identity where untainted = runIdentity- untainted# = unsafeCoerce+ untainted# = UNSAFELY(runIdentity) {-# INLINE untainted #-}- tainted# = unsafeCoerce+ tainted# = UNSAFELY(Identity) {-# INLINE tainted# #-} -- | 'Control.Lens.Fold.backwards'@@ -121,3 +135,58 @@ instance (Settable f, Settable g) => Settable (Compose f g) where untainted = untainted . untainted . getCompose {-# INLINE untainted #-}++-----------------------------------------------------------------------------+-- Isomorphisms+-----------------------------------------------------------------------------++-- | Used to provide overloading of isomorphism application+--+-- An instance of 'Isomorphic' is a 'Category' with a canonical mapping to it from the+-- category of isomorphisms over Haskell types.+class Category k => Isomorphic k where+ -- | Build a simple isomorphism from a pair of inverse functions+ --+ -- @+ -- 'view' ('iso' f g) ≡ f+ -- 'view' ('from' ('iso' f g)) ≡ g+ -- 'set' ('iso' f g) h ≡ g '.' h '.' f+ -- 'set' ('from' ('iso' f g)) h ≡ f '.' h '.' g+ -- @+ iso :: Functor f => (s -> a) -> (b -> t) -> k (a -> f b) (s -> f t)++instance Isomorphic (->) where+ iso sa bt afb s = bt <$> afb (sa s)+ {-# INLINE iso #-}++-----------------------------------------------------------------------------+-- Prisms+-----------------------------------------------------------------------------++-- | Used to provide overloading of prisms.+--+-- An instance of 'Prismatic' is a 'Category' with a canonical mapping to it from the category+-- of embedding-projection pairs over Haskell types.+class Isomorphic k => Prismatic k where+ -- | Build a 'Control.Lens.Prism.Prism'.+ --+ -- @'Either' t a@ is used instead of @'Maybe' a@ to permit the types of @s@ and @t@ to differ.+ prism :: Applicative f => (b -> t) -> (s -> Either t a) -> k (a -> f b) (s -> f t)++instance Prismatic (->) where+ prism bt seta afb = either pure (fmap bt . afb) . seta+ {-# INLINE prism #-}++----------------------------------------------------------------------------+-- Indexed Internals+-----------------------------------------------------------------------------++-- | This class permits overloading of function application for things that+-- also admit a notion of a key or index.+class Indexable i k where+ -- | Build a function from an 'Indexed' function+ indexed :: ((i -> a) -> b) -> k a b++instance Indexable i (->) where+ indexed f = f . const+ {-# INLINE indexed #-}
src/Control/Lens/Combinators.hs view
@@ -12,9 +12,10 @@ ( (<$!>), (<$!), (<&>) ) where -import Data.Functor+import Data.Functor ((<$>)) -infixr 4 <$!>, <$!, <&>+infixl 4 <$!>, <$!+infixl 1 <&> -- | A strict version of ('Data.Functor.<$>') for monads. --
src/Control/Lens/Fold.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold@@ -41,6 +40,8 @@ , (^..) , (^?) , (^?!)+ , preview+ , previews -- ** Building Folds --, folds , folding@@ -67,8 +68,8 @@ , concatMapOf, concatOf , elemOf, notElemOf , lengthOf- , nullOf- , headOf, lastOf+ , nullOf, notNullOf+ , firstOf, lastOf , maximumOf, minimumOf , maximumByOf, minimumByOf , findOf@@ -77,6 +78,8 @@ , foldrMOf, foldlMOf -- * Storing Folds , ReifiedFold(..)+ -- * Deprecated+ , headOf ) where import Control.Applicative as Applicative@@ -87,6 +90,7 @@ import Control.Lens.Internal.Combinators import Control.Lens.Type import Control.Monad+import Control.Monad.Reader import Data.Foldable as Foldable import Data.Maybe import Data.Monoid@@ -119,11 +123,23 @@ -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'.+--+-- >>> [1,2,3,4]^..folding tail+-- [2,3,4] folding :: (Foldable f, Applicative g, Gettable g) => (s -> f a) -> LensLike g s t a b folding sfa agb = coerce . traverse_ agb . sfa {-# INLINE folding #-} -- | Obtain a 'Fold' from any 'Foldable'.+--+-- >>> Just 3^..folded+-- [3]+--+-- >>> Nothing^..folded+-- []+--+-- >>> [(1,2),(3,4)]^..folded.both+-- [1,2,3,4] folded :: Foldable f => Fold (f a) a folded f = coerce . getFolding . foldMap (folding# f) {-# INLINE folded #-}@@ -131,6 +147,9 @@ -- | Fold by repeating the input forever. -- -- @'repeat' ≡ 'toListOf' 'repeated'@+--+-- >>> 5^..taking 20 repeated+-- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] repeated :: Fold a a repeated f a = as where as = f a *> as {-# INLINE repeated #-}@@ -138,6 +157,9 @@ -- | A fold that replicates its input @n@ times. -- -- @'replicate' n ≡ 'toListOf' ('replicated' n)@+--+-- >>> 5^..replicated 20+-- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] replicated :: Int -> Fold a a replicated n0 f a = go n0 where m = f a@@ -147,8 +169,8 @@ -- | Transform a fold into a fold that loops over its elements over and over. ----- >>> take 6 $ toListOf (cycled traverse) [1,2,3]--- [1,2,3,1,2,3]+-- >>> [1,2,3]^..taking 7 (cycled traverse)+-- [1,2,3,1,2,3,1] cycled :: (Applicative f, Gettable f) => LensLike f s t a b -> LensLike f s t a b cycled l f a = as where as = l f a *> as {-# INLINE cycled #-}@@ -156,6 +178,9 @@ -- | Build a fold that unfolds its values from a seed. -- -- @'Prelude.unfoldr' ≡ 'toListOf' . 'unfolded'@+--+-- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1))+-- [10,9,8,7,6,5,4,3,2,1] unfolded :: (b -> Maybe (a, b)) -> Fold b a unfolded f g b0 = go b0 where go b = case f b of@@ -190,7 +215,7 @@ -- | This allows you to traverse the elements of a 'Control.Lens.Traversal.Traversal' or 'Fold' in the opposite order. -- This will demote an 'Control.Lens.IndexedTraversal.IndexedTraversal' or 'Control.Lens.IndexedFold.IndexedFold' to a regular 'Control.Lens.Traversal.Traversal' or 'Fold',--- repectively; to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead.+-- respectively; to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead. -- -- Note: 'backwards' should have no impact on a 'Getter', 'Control.Lens.Setter.Setter', 'Lens' or 'Control.Lens.Iso.Iso'. --@@ -226,7 +251,7 @@ => (a -> Bool) -> Getting (Endo (f s, f s)) s s a a -> LensLike f s s a a-droppingWhile p l f = fst . foldrOf l (\a r -> let s = f a *> snd r in if p a then (fst r, s) else (s, s)) (noEffect, noEffect)+droppingWhile p l f = fst . foldrOf l (\a r -> let s = f a *> snd r in (if p a then fst r else s, s)) (noEffect, noEffect) {-# INLINE droppingWhile #-} --------------------------@@ -244,6 +269,7 @@ -- 'foldMapOf' :: 'Simple' 'Lens' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> s -> r+-- 'foldMapOf' :: 'Monoid' r => 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> r) -> s -> r -- @ foldMapOf :: Getting r s t a b -> (a -> r) -> s -> r foldMapOf l f = runAccessor# (l (accessor# f))@@ -260,6 +286,7 @@ -- 'foldOf' :: 'Simple' 'Lens' s m -> s -> m -- 'foldOf' :: 'Simple' 'Control.Lens.Iso.Iso' s m -> s -> m -- 'foldOf' :: 'Monoid' m => 'Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m+-- 'foldOf' :: 'Monoid' m => 'Simple' 'Control.Lens.Prism.Prism' s m -> s -> m -- @ foldOf :: Getting a s t a b -> s -> a foldOf l = runAccessor# (l Accessor)@@ -276,6 +303,7 @@ -- 'foldrOf' :: 'Simple' 'Lens' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r -> r) -> r -> s -> r+-- 'foldrOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf :: Getting (Endo r) s t a b -> (a -> r -> r) -> r -> s -> r foldrOf l f z t = appEndo (foldMapOf l (endo# f) t) z@@ -292,6 +320,7 @@ -- 'foldlOf' :: 'Simple' 'Lens' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (r -> a -> r) -> r -> s -> r+-- 'foldlOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf :: Getting (Dual (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r foldlOf l f z t = appEndo (getDual (foldMapOf l (dual# (endo# (flip f))) t)) z@@ -313,6 +342,7 @@ -- 'toListOf' :: 'Simple' 'Lens' s a -> s -> [a] -- 'toListOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> [a] -- 'toListOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> [a]+-- 'toListOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> [a] -- @ toListOf :: Getting (Endo [a]) s t a b -> s -> [a] toListOf l = foldrOf l (:) []@@ -340,9 +370,10 @@ -- ('^..') :: s -> 'Simple' 'Lens' s a -> [a] -- ('^..') :: s -> 'Simple' 'Control.Lens.Iso.Iso' s a -> [a] -- ('^..') :: s -> 'Simple' 'Control.Lens.Traversal.Traversal' s a -> [a]+-- ('^..') :: s -> 'Simple' 'Control.Lens.Prism.Prism' s a -> [a] -- @-(^..) :: s -> Getting [a] s t a b -> [a]-s ^.. l = foldMapOf l return s+(^..) :: s -> Getting (Endo [a]) s t a b -> [a]+s ^.. l = toListOf l s {-# INLINE (^..) #-} -- | Returns 'True' if every target of a 'Fold' is 'True'.@@ -360,6 +391,7 @@ -- 'andOf' :: 'Simple' 'Lens' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool'+-- 'andOf' :: 'Simple' 'Control.Lens.Prism.Prism' s 'Bool' -> s -> 'Bool' -- @ andOf :: Getting All s t Bool b -> s -> Bool andOf l = getAll# (foldMapOf l All)@@ -380,6 +412,7 @@ -- 'orOf' :: 'Simple' 'Lens' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool'+-- 'orOf' :: 'Simple' 'Control.Lens.Prism.Prism' s 'Bool' -> s -> 'Bool' -- @ orOf :: Getting Any s t Bool b -> s -> Bool orOf l = getAny# (foldMapOf l Any)@@ -401,6 +434,7 @@ -- 'anyOf' :: 'Simple' 'Lens' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'anyOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ anyOf :: Getting Any s t a b -> (a -> Bool) -> s -> Bool anyOf l f = getAny# $ foldMapOf l (any# f)@@ -421,6 +455,7 @@ -- 'allOf' :: 'Simple' 'Lens' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'allOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ allOf :: Getting All s t a b -> (a -> Bool) -> s -> Bool allOf l f = getAll# $ foldMapOf l (all# f)@@ -441,6 +476,7 @@ -- 'productOf' :: 'Simple' 'Lens' s a -> s -> a -- 'productOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> a -- 'productOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a+-- 'productOf' :: 'Num' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> a -- @ productOf :: Getting (Product a) s t a b -> s -> a productOf l = getProduct# $ foldMapOf l Product@@ -471,6 +507,7 @@ -- 'sumOf' :: 'Simple' 'Lens' s a -> s -> a -- 'sumOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a+-- 'sumOf' :: 'Num' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> a -- @ sumOf :: Getting (Sum a) s t a b -> s -> a sumOf l = getSum# $ foldMapOf l Sum@@ -502,6 +539,7 @@ -- 'traverseOf_' :: 'Functor' f => 'Simple' 'Lens' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Functor' f => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> f r) -> s -> f ()+-- 'traverseOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> f r) -> s -> f () -- @ traverseOf_ :: Functor f => Getting (Traversed f) s t a b -> (a -> f r) -> s -> f () traverseOf_ l f = getTraversed# (foldMapOf l (traversed# (void . f)))@@ -524,6 +562,7 @@ -- 'forOf_' :: 'Functor' f => 'Simple' 'Lens' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Functor' f => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> (a -> f r) -> f ()+-- 'forOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> (a -> f r) -> f () -- @ forOf_ :: Functor f => Getting (Traversed f) s t a b -> s -> (a -> f r) -> f () forOf_ = flip . traverseOf_@@ -534,13 +573,14 @@ -- @'sequenceA_' ≡ 'sequenceAOf_' 'folded'@ -- -- @--- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f ()) -> s -> f ()--- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f ()) -> s -> f ()--- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Lens' s (f ()) -> s -> f ()--- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Iso' s (f ()) -> s -> f ()--- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s (f ()) -> s -> f ()+-- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f a) -> s -> f ()+-- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f a) -> s -> f ()+-- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Lens' s (f a) -> s -> f ()+-- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Iso' s (f a) -> s -> f ()+-- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s (f a) -> s -> f ()+-- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Prism.Prism' s (f a) -> s -> f () -- @-sequenceAOf_ :: Functor f => Getting (Traversed f) s t (f ()) b -> s -> f ()+sequenceAOf_ :: Functor f => Getting (Traversed f) s t (f a) b -> s -> f () sequenceAOf_ l = getTraversed# (foldMapOf l (traversed# void)) {-# INLINE sequenceAOf_ #-} @@ -554,6 +594,7 @@ -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Lens' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m r) -> s -> m ()+-- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> m r) -> s -> m () -- @ mapMOf_ :: Monad m => Getting (Sequenced m) s t a b -> (a -> m r) -> s -> m () mapMOf_ l f = getSequenced# (foldMapOf l (sequenced# (liftM skip . f)))@@ -573,6 +614,7 @@ -- 'forMOf_' :: 'Monad' m => 'Simple' 'Lens' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> (a -> m r) -> m ()+-- 'forMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> (a -> m r) -> m () -- @ forMOf_ :: Monad m => Getting (Sequenced m) s t a b -> s -> (a -> m r) -> m () forMOf_ = flip . mapMOf_@@ -588,6 +630,7 @@ -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Lens' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Iso.Iso' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s (m a) -> s -> m ()+-- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Prism.Prism' s (m a) -> s -> m () -- @ sequenceOf_ :: Monad m => Getting (Sequenced m) s t (m a) b -> s -> m () sequenceOf_ l = getSequenced# (foldMapOf l (sequenced# (liftM skip)))@@ -603,6 +646,7 @@ -- 'asumOf' :: 'Alternative' f => 'Simple' 'Lens' s a -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> f a+-- 'asumOf' :: 'Alternative' f => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> f a -- @ asumOf :: Alternative f => Getting (Endo (f a)) s t (f a) b -> s -> f a asumOf l = foldrOf l (<|>) Applicative.empty@@ -618,6 +662,7 @@ -- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Lens' s a -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> m a+-- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> m a -- @ msumOf :: MonadPlus m => Getting (Endo (m a)) s t (m a) b -> s -> m a msumOf l = foldrOf l mplus mzero@@ -636,6 +681,7 @@ -- 'elemOf' :: 'Eq' a => 'Simple' 'Lens' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> 'Bool'+-- 'elemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> a -> s -> 'Bool' -- @ elemOf :: Eq a => Getting Any s t a b -> a -> s -> Bool elemOf l = anyOf l . (==)@@ -651,6 +697,7 @@ -- 'notElemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Simple' 'Lens' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> 'Bool'+-- 'notElemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> a -> s -> 'Bool' -- @ notElemOf :: Eq a => Getting All s t a b -> a -> s -> Bool notElemOf l = allOf l . (/=)@@ -713,21 +760,11 @@ lengthOf l = getSum# (foldMapOf l (\_ -> Sum 1)) {-# INLINE lengthOf #-} --- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result--- from a 'Getter' or 'Lens'. See also ('^?').------ @'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'headOf' 'folded'@------ @--- 'headOf' :: 'Getter' s a -> s -> 'Maybe' a--- 'headOf' :: 'Fold' s a -> s -> 'Maybe' a--- 'headOf' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a--- 'headOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Maybe' a--- 'headOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a--- @+-- | A deprecated alias for 'firstOf' headOf :: Getting (First a) s t a b -> s -> Maybe a headOf l = getFirst# (foldMapOf l (first# Just)) {-# INLINE headOf #-}+{-# DEPRECATED headOf "`headOf' will be removed in 3.8. (Use `preview' or `firstOf')" #-} -- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'.@@ -735,7 +772,7 @@ -- When using a 'Control.Lens.Traversal.Traversal' as a partial 'Control.Lens.Type.Lens', or a 'Fold' as a partial 'Getter' this can be a convenient -- way to extract the optional value. ----- @('^?') ≡ 'flip' 'headOf'@+-- @('^?') ≡ 'flip' 'preview'@ -- -- @ -- ('^?') :: s -> 'Getter' s a -> 'Maybe' a@@ -761,10 +798,24 @@ a ^?! l = fromMaybe (error "(^?!): empty Fold") $ getFirst (foldMapOf l (first# Just) a) {-# INLINE (^?!) #-} --- | Perform a safe 'last' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result+-- | Retrieve the 'First' entry of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. -- -- @+-- 'firstOf' :: 'Getter' s a -> s -> 'Maybe' a+-- 'firstOf' :: 'Fold' s a -> s -> 'Maybe' a+-- 'firstOf' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a+-- 'firstOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Maybe' a+-- 'firstOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a+-- @+firstOf :: Getting (First a) s t a b -> s -> Maybe a+firstOf l = getFirst# (foldMapOf l (first# Just))+{-# INLINE firstOf #-}++-- | Retrieve the 'Last' entry of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result+-- from a 'Getter' or 'Lens'.+--+-- @ -- 'lastOf' :: 'Getter' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Fold' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a@@ -800,7 +851,33 @@ nullOf l = getAll# (foldMapOf l (\_ -> All False)) {-# INLINE nullOf #-} + -- |+-- Returns 'True' if this 'Fold' or 'Control.Lens.Traversal.Traversal' has any targets in the given container.+--+-- Note: 'notNullOf' on a valid 'Control.Lens.Iso.Iso', 'Lens' or 'Getter' should always return 'True'+--+-- @'null' ≡ 'notNullOf' 'folded'@+--+-- This may be rather inefficient compared to the @'not' . 'null'@ check of many containers.+--+-- >>> notNullOf _1 (1,2)+-- True+--+-- @'notNullOf' ('folded' '.' '_1' '.' 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool'@+--+-- @+-- 'notNullOf' :: 'Getter' s a -> s -> 'Bool'+-- 'notNullOf' :: 'Fold' s a -> s -> 'Bool'+-- 'notNullOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Bool'+-- 'notNullOf' :: 'Simple' 'Lens' s a -> s -> 'Bool'+-- 'notNullOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Bool'+-- @+notNullOf :: Getting Any s t a b -> s -> Bool+notNullOf l = getAny# (foldMapOf l (\_ -> Any True))+{-# INLINE notNullOf #-}++-- | -- Obtain the maximum element (if any) targeted by a 'Fold' or 'Control.Lens.Traversal.Traversal' -- -- Note: maximumOf on a valid 'Control.Lens.Iso.Iso', 'Lens' or 'Getter' will always return 'Just' a value.@@ -916,7 +993,7 @@ mf x (Just y) = Just (f x y) {-# INLINE foldr1Of #-} --- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and strutures such+-- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and structures such -- that the lens views at least one element of the structure. -- -- @@@ -1009,3 +1086,61 @@ -- | Useful for storing folds in containers. newtype ReifiedFold s a = ReifyFold { reflectFold :: Fold s a }++-- * Previewing++-- | Retrieve the first value targeted by a 'Fold' or 'Control.Lens.Traversal.Traversal' (or 'Just' the result+-- from a 'Getter' or 'Lens'). See also ('^?').+--+-- @'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded'@+--+-- This is usually applied in the reader monad @(->) s@.+--+-- @+-- 'preview' :: 'Getter' s a -> s -> 'Maybe' a+-- 'preview' :: 'Fold' s a -> s -> 'Maybe' a+-- 'preview' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a+-- 'preview' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Maybe' a+-- 'preview' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a+-- @+--+-- However, it may be useful to think of its full generality when working with+-- a monad transformer stack:+--+-- @+-- 'preview' :: MonadReader s m => 'Getter' s a -> m ('Maybe' a)+-- 'preview' :: MonadReader s m => 'Fold' s a -> m ('Maybe' a)+-- 'preview' :: MonadReader s m => 'Simple' 'Lens' s a -> m ('Maybe' a)+-- 'preview' :: MonadReader s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> m ('Maybe' a)+-- 'preview' :: MonadReader s m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> m ('Maybe' a)+-- @+preview :: MonadReader s m => Getting (First a) s t a b -> m (Maybe a)+preview l = asks (getFirst# (foldMapOf l (first# Just)))+{-# INLINE preview #-}++-- | Retrieve a function of the first value targeted by a 'Fold' or+-- 'Control.Lens.Traversal.Traversal' (or 'Just' the result from a 'Getter' or 'Lens').+--+-- This is usually applied in the reader monad @(->) s@.+--+-- @+-- 'previews' :: 'Getter' s a -> (a -> r) -> s -> 'Maybe' a+-- 'previews' :: 'Fold' s a -> (a -> r) -> s -> 'Maybe' a+-- 'previews' :: 'Simple' 'Lens' s a -> (a -> r) -> s -> 'Maybe' a+-- 'previews' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> 'Maybe' a+-- 'previews' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> s -> 'Maybe' a+-- @+--+-- However, it may be useful to think of its full generality when working with+-- a monad transformer stack:+--+-- @+-- 'previews' :: MonadReader s m => 'Getter' s a -> (a -> r) -> m ('Maybe' r)+-- 'previews' :: MonadReader s m => 'Fold' s a -> (a -> r) -> m ('Maybe' r)+-- 'previews' :: MonadReader s m => 'Simple' 'Lens' s a -> (a -> r) -> m ('Maybe' r)+-- 'previews' :: MonadReader s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m ('Maybe' r)+-- 'previews' :: MonadReader s m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m ('Maybe' r)+-- @+previews :: MonadReader s m => Getting (First r) s t a b -> (a -> r) -> m (Maybe r)+previews l f = asks (getFirst# (foldMapOf l (first# (Just . f))))+{-# INLINE previews #-}
src/Control/Lens/Getter.hs view
@@ -2,10 +2,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}--- {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------@@ -57,9 +55,11 @@ , views , use , uses- , peruse- , peruses-+ -- * Simple Getter Operations+ , view'+ , views'+ , use'+ , uses' -- * Storing Getters , ReifiedGetter(..) , Gettable@@ -69,11 +69,16 @@ import Control.Lens.Classes import Control.Lens.Internal import Control.Lens.Internal.Combinators-import Control.Monad.Reader.Class as Reader-import Control.Monad.State.Class as State+import Control.Monad.Reader.Class as Reader+import Control.Monad.State as State -- $setup -- >>> import Control.Lens+-- >>> import Data.List.Lens+-- >>> import Debug.SimpleReflect.Expr+-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g infixl 8 ^., ^& infixl 1 &@@ -89,17 +94,35 @@ -- for inference. Here it is supplied for notational convenience and given a precedence that allows it -- to be nested inside uses of ('$'). --+-- >>> a & f+-- f a+-- -- >>> "hello" & length & succ -- 6+--+-- This combinator is commonly used when applying multiple lens operations in sequence.+--+-- >>> ("hello","world") & _1.element 0 .~ 'j' & _1.element 4 .~ 'y'+-- ("jelly","world")+--+-- This reads somewhat similar to:+--+-- >>> flip execState ("hello","world") $ do _1.element 0 .= 'j'; _1.element 4 .= 'y'+-- ("jelly","world")+--+ (&) :: a -> (a -> b) -> b a & f = f a {-# INLINE (&) #-} -- | A version of ('&') with much tighter precedence that can be interleaved with ('^.') --+-- >>> a ^& f+-- f a+-- -- >>> "hello" ^& length -- 5--- >>> import Data.List.Lens+-- -- >>> ("hello","world")^._1^&reverse^?!_head -- 'o' (^&) :: a -> (a -> b) -> b@@ -122,10 +145,12 @@ -- | Build a 'Getter' from an arbitrary Haskell function. ----- @'to' f . 'to' g = 'to' (g . f)@+-- @'to' f . 'to' g ≡ 'to' (g . f)@ ----- @a '^.' 'to' f = f a@+-- @a '^.' 'to' f ≡ f a@ --+-- >>> a ^.to f+-- f a -- -- >>> ("hello","world")^.to snd -- "world"@@ -141,6 +166,12 @@ -- |+-- When you see this in a type signature it indicates that you can+-- pass the function a 'Control.Lens.Type.Lens', 'Getter',+-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold',+-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of+-- the indexed variants, and it will just \"do the right thing\".+-- -- Most 'Getter' combinators are able to be used with both a 'Getter' or a -- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be -- monomorphic in what we are going to extract with 'Const'. To be compatible@@ -152,6 +183,7 @@ -- you can pass a 'Control.Lens.Fold.Fold' (or -- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a -- 'Getter' or 'Control.Lens.Type.Lens'.+-- type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t -------------------------------------------------------------------------------@@ -163,8 +195,11 @@ -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- at a monoidal values. ----- @'view' . 'to' = 'id'@+-- @'view' . 'to' ≡ 'id'@ --+-- >>> view (to f) a+-- f a+-- -- >>> view _2 (1,"hello") -- "hello" --@@ -175,8 +210,8 @@ -- "world" -- ----- It may be useful to think of 'view' as having one of these more restrictive--- signatures:+-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',+-- It may be useful to think of it as having one of these more restrictive signatures: -- -- @ -- 'view' :: 'Getter' s a -> s -> a@@ -185,8 +220,18 @@ -- 'view' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> s -> a -- 'view' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m -- @-view :: Getting a s t a b -> s -> a-view l = runAccessor# (l Accessor)+--+-- In a more general setting, such as when working with a monad transformer stack you can use:+--+-- @+-- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a+-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a+-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a+-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a+-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a+-- @+view :: MonadReader s m => Getting a s t a b -> m a+view l = Reader.asks (runAccessor# (l Accessor)) {-# INLINE view #-} -- | View the value of a 'Getter', 'Control.Lens.Iso.Iso',@@ -197,11 +242,17 @@ -- It may be useful to think of 'views' as having these more restrictive -- signatures: ----- @'views' l f = 'view' (l '.' 'to' f)@+-- @'views' l f ≡ 'view' (l '.' 'to' f)@ --+-- >>> views (to f) g a+-- g (f a)+-- -- >>> views _2 length (1,"hello") -- 5 --+-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',+-- It may be useful to think of it as having one of these more restrictive signatures:+-- -- @ -- 'views' :: 'Getter' s a -> (a -> r) -> s -> r -- 'views' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m@@ -209,8 +260,18 @@ -- 'views' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> s -> r -- 'views' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m) -> s -> m -- @-views :: Getting r s t a b -> (a -> r) -> s -> r-views l f = runAccessor# (l (accessor# f))+--+-- In a more general setting, such as when working with a monad transformer stack you can use:+--+-- @+-- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a+-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a+-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a+-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a+-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a+-- @+views :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r+views l f = Reader.asks (runAccessor# (l (accessor# f))) {-# INLINE views #-} -- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or@@ -220,8 +281,11 @@ -- -- This is the same operation as 'view', only infix. ----- @'to' f '^$' x = f x@+-- @'to' f '^$' x ≡ f x@ --+-- >>> to f ^$ x+-- f x+-- -- >>> _2 ^$ (1, "hello") -- "hello" --@@ -245,6 +309,9 @@ -- The fixity and semantics are such that subsequent field accesses can be -- performed with ('Prelude..') --+-- >>> (a,b)^._2+-- b+-- -- >>> ("hello","world")^._2 -- "world" --@@ -273,6 +340,12 @@ -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- to a monoidal value. --+-- >>> evalState (use _1) (a,b)+-- a+--+-- >>> evalState (use _1) ("hello","world")+-- "hello"+-- -- @ -- 'use' :: 'MonadState' s m => 'Getter' s a -> m a -- 'use' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r@@ -290,6 +363,9 @@ -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that -- points to a monoidal value. --+-- >>> evalState (uses _1 length) ("hello","world")+-- 5+-- -- @ -- 'uses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r -- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r@@ -301,43 +377,153 @@ uses l f = State.gets (views l f) {-# INLINE uses #-} ----------------------------------------------------------------------------------- MonadReader-------------------------------------------------------------------------------- +------------------------------------------------------------------------------+-- Accessing State, Simplified+------------------------------------------------------------------------------+ -- |--- Query the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or+-- This is a type restricted version of 'use' that expects a 'Simple' 'Getter'.+--+-- Use the target of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or -- 'Getter' in the current state, or use a summary of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- to a monoidal value. --+-- This use of this combinator may aid type-inference when working with lenses or traversals that+-- have non-defaultable typeclass constraints on their arguments.+--+-- >>> evalState (use' _1) (a,b)+-- a+--+--+-- >>> evalState (use' _1) ("hello","world")+-- "hello"+-- -- @--- 'peruse' :: 'MonadReader' s m => 'Getter' s a -> m a--- 'peruse' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a--- 'peruse' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a--- 'peruse' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a--- 'peruse' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a+-- 'use'' :: 'MonadState' s m => 'Getter' s a -> m a+-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r+-- 'use'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a+-- 'use'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a+-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s r -> m r -- @-peruse :: MonadReader s m => Getting a s t a b -> m a-peruse l = Reader.asks (^.l)-{-# INLINE peruse #-}+use' :: MonadState s m => Getting a s s a a -> m a+use' l = State.gets (view' l)+{-# INLINE use' #-} -- |+-- This is a type restricted version of 'uses' that expects a 'Simple' 'Getter'.+-- -- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or -- 'Getter' in the current state, or use a summary of a+-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that+-- points to a monoidal value.+--+-- >>> evalState (uses' _1 length) ("hello","world")+-- 5+--+-- @+-- 'uses'' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r+-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r+-- 'uses'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r+-- 'uses'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r+-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r+-- @+uses' :: MonadState s m => Getting r s s a a -> (a -> r) -> m r+uses' l f = State.gets (views' l f)+{-# INLINE uses' #-}++------------------------------------------------------------------------------+-- Viewing, Simplified+------------------------------------------------------------------------------++-- | This is a type restricted version of 'view' that expects a 'Simple' 'Getter'.+--+-- View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or+-- 'Control.Lens.Type.Lens' or the result of folding over all the results of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points--- to a monoidal value.+-- at a monoidal values. --+-- @'view'' . 'to' ≡ 'id'@+--+-- >>> view' (to f) a+-- f a+--+-- >>> view' _2 (1,"hello")+-- "hello"+--+-- >>> view' (to succ) 5+-- 6+--+-- >>> view' (_2._1) ("hello",("world","!!!"))+-- "world"+--+-- As 'view'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',+-- It may be useful to think of it as having one of these more restrictive signatures:+-- -- @--- 'peruses' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r--- 'peruses' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r--- 'peruses' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r--- 'peruses' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r--- 'peruses' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r+-- 'view'' :: 'Getter' s a -> s -> a+-- 'view'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s m -> s -> m+-- 'view'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> s -> a+-- 'view'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> s -> a+-- 'view'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m -- @-peruses :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r-peruses l f = Reader.asks (views l f)-{-# INLINE peruses #-}+--+-- In a more general setting, such as when working with a monad transformer stack you can use:+--+-- @+-- 'view'' :: 'MonadReader' s m => 'Getter' s a -> m a+-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a+-- 'view'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a+-- 'view'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a+-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a+-- @+view' :: MonadReader s m => Getting a s s a a -> m a+view' l = Reader.asks (runAccessor# (l Accessor))+{-# INLINE view' #-}++-- | This is a type restricted version of 'views' that expects a 'Simple' 'Getter'.+--+-- View the value of a 'Getter', 'Control.Lens.Iso.Iso',+-- 'Control.Lens.Type.Lens' or the result of folding over the result of mapping+-- the targets of a 'Control.Lens.Fold.Fold' or+-- 'Control.Lens.Traversal.Traversal'.+--+-- It may be useful to think of 'perviews' as having these more restrictive+-- signatures:+--+-- @'views'' l f ≡ 'view'' (l '.' 'to' f)@+--+-- >>> views' _2 length (1,"hello")+-- 5+--+-- As 'views'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',+-- It may be useful to think of it as having one of these more restrictive signatures:+--+-- @+-- 'views'' :: 'Getter' s a -> (a -> r) -> s -> r+-- 'views'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m+-- 'views'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> r+-- 'views'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> s -> r+-- 'views'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m) -> s -> m+-- @+--+-- In a more general setting, such as when working with a monad transformer stack you can use:+--+-- @+-- 'views'' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r+-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r+-- 'views'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r+-- 'views'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r+-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r+-- @+views' :: MonadReader s m => Getting r s s a a -> (a -> r) -> m r+views' l f = Reader.asks (runAccessor# (l (accessor# f)))+{-# INLINE views' #-}++------------------------------------------------------------------------------+-- Reified Getters+------------------------------------------------------------------------------ -- | Useful for storing getters in containers. newtype ReifiedGetter s a = ReifyGetter { reflectGetter :: Getter s a }
src/Control/Lens/Indexed.hs view
@@ -16,88 +16,64 @@ -- Combinators for working with 'Indexed' functions. ---------------------------------------------------------------------------- module Control.Lens.Indexed- (+ ( Indexable(..) -- * Indexed Functions- Indexed(..)- , Indexable- , Index(..)+ , Indexed(..) , (<.>), (<.), (.>) , icompose- , reindex- , indexed+ , reindexed+ -- * Indexing existing lenses, traversals, etc.+ , indexing ) where +import Control.Lens.Classes import Control.Lens.Internal infixr 9 <.>, <., .> --- | Permit overloading of function application for things that also admit a notion of a key or index.---- | Provides overloading for 'Indexed' functions.-class Indexed i k where- -- | Build a function from an 'Indexed' function- index :: ((i -> a) -> b) -> k a b---- | Type alias for passing around polymorphic 'Indexed' functions that can be called 'withIndex' or--- directly as a function-type Indexable i a b = forall k. Indexed i k => k a b--instance Indexed i (->) where- index f = f . const- {-# INLINE index #-}---- | A function with access to a index. This constructor may be useful when you need to store--- a 'Indexable' in a container to avoid @ImpredicativeTypes@.-newtype Index i a b = Index { withIndex :: (i -> a) -> b }---- | Using an equality witness to avoid potential overlapping instances--- and aid dispatch.-instance i ~ j => Indexed i (Index j) where- index = Index- {-# INLINE index #-}- -- | Compose an 'Indexed' function with a non-indexed function. ----- Mnemonically, the @<@ points to the index we want to preserve.-(<.) :: Indexed i k => Index i b c -> (a -> b) -> k a c-Index ibc <. ab = index $ \ia -> ibc (ab . ia)+-- Mnemonically, the @<@ points to the indexing we want to preserve.+(<.) :: Indexable i k => Indexed i b c -> (a -> b) -> k a c+Indexed ibc <. ab = indexed $ \ia -> ibc (ab . ia) {-# INLINE (<.) #-} -- | Compose a non-indexed function with an 'Indexed' function. ----- Mnemonically, the @>@ points to the index we want to preserve.-(.>) :: Indexed i k => (b -> c) -> Index i a b -> k a c-bc .> Index iab = index (bc . iab)+-- Mnemonically, the @>@ points to the indexing we want to preserve.+(.>) :: Indexable i k => (b -> c) -> Indexed i a b -> k a c+bc .> Indexed iab = indexed (bc . iab) {-# INLINE (.>) #-} -- | Remap the index.-reindex :: Indexed j k => (i -> j) -> Index i a b -> k a b-reindex ij (Index iab) = index $ \ ja -> iab $ \i -> ja (ij i)-{-# INLINE reindex #-}+reindexed :: Indexable j k => (i -> j) -> Indexed i a b -> k a b+reindexed ij (Indexed iab) = indexed $ \ ja -> iab $ \i -> ja (ij i)+{-# INLINE reindexed #-} -- | Composition of 'Indexed' functions -- -- Mnemonically, the @\<@ and @\>@ points to the fact that we want to preserve the indices.-(<.>) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c+(<.>) :: Indexable (i, j) k => Indexed i b c -> Indexed j a b -> k a c f <.> g = icompose (,) f g {-# INLINE (<.>) #-} --- | Composition of 'Indexed' functions with a user supplied function for combining indexs-icompose :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c-icompose ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j)+-- | Composition of 'Indexed' functions with a user supplied function for combining indices+icompose :: Indexable k r => (i -> j -> k) -> Indexed i b c -> Indexed j a b -> r a c+icompose ijk (Indexed ibc) (Indexed jab) = indexed $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) {-# INLINE icompose #-} --- | Transform an 'Traversal' into an 'Control.Lens.IndexedTraversal.IndexedTraversal', a 'Fold' into an 'Control.Lens.IndexedFold.IndexedFold', etc.+-- | Transform an 'Traversal' into an 'Control.Lens.IndexedTraversal.IndexedTraversal' or+-- a 'Fold' into an 'Control.Lens.IndexedFold.IndexedFold', etc. -- -- @--- 'indexed' :: 'Control.Lens.Traversal.Traversal' s t a b -> 'Control.Lens.IndexedTraversal.IndexedTraversal' 'Int' s t a b--- 'indexed' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b--- 'indexed' :: 'Control.Lens.Fold.Fold' s t -> 'Control.Lens.IndexedFold.IndexedFold' 'Int' s t--- 'indexed' :: 'Control.Lens.Iso.Iso' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b--- 'indexed' :: 'Control.Lens.Getter.Getter' s t -> 'Control.Lens.IndexedGetter.IndexedGetter' 'Int' s t a b+-- 'indexing' :: 'Control.Lens.Traversal.Traversal' s t a b -> 'Control.Lens.IndexedTraversal.IndexedTraversal' 'Int' s t a b+-- 'indexing' :: 'Control.Lens.Prism.Prism' s t a b -> 'Control.Lens.IndexedLens.IndexedTraversal' 'Int' s t a b+-- 'indexing' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b+-- 'indexing' :: 'Control.Lens.Iso.Iso' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b+-- 'indexing' :: 'Control.Lens.Fold.Fold' s t -> 'Control.Lens.IndexedFold.IndexedFold' 'Int' s t+-- 'indexing' :: 'Control.Lens.Getter.Getter' s t -> 'Control.Lens.IndexedGetter.IndexedGetter' 'Int' s t a b -- @-indexed :: Indexed Int k => ((a -> Indexing f b) -> s -> Indexing f t) -> k (a -> f b) (s -> f t)-indexed l = index $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> (iafb i a, i + 1))) s) 0 of+indexing :: Indexable Int k => ((a -> Indexing f b) -> s -> Indexing f t) -> k (a -> f b) (s -> f t)+indexing l = indexed $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> i `seq` (iafb i a, i + 1))) s) 0 of (r, _) -> r-{-# INLINE indexed #-}-+{-# INLINE indexing #-}
src/Control/Lens/IndexedFold.hs view
@@ -67,11 +67,12 @@ ------------------------------------------------------------------------------ -- | Every 'IndexedFold' is a valid 'Control.Lens.Fold.Fold'.-type IndexedFold i s a = forall k f. (Indexed i k, Applicative f, Gettable f) => k (a -> f a) (s -> f s)+type IndexedFold i s a = forall k f.+ (Indexable i k, Applicative f, Gettable f) => k (a -> f a) (s -> f s) -- | -- Fold an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' by mapping indices and values to an arbitrary 'Monoid' with access--- to the index @i@.+-- to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldMapOf' is more flexible in what it accepts. --@@ -89,7 +90,7 @@ -- | -- Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with--- access to the index @i@.+-- access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldrOf' is more flexible in what it accepts. --@@ -107,7 +108,7 @@ -- | -- Left-associative fold of the parts of a structure that are viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with--- access to the index @i@.+-- access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf' is more flexible in what it accepts. --@@ -125,7 +126,7 @@ -- | -- Return whether or not any element viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal'--- satisfy a predicate, with access to the index @i@.+-- satisfy a predicate, with access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.anyOf' is more flexible in what it accepts. --@@ -143,7 +144,7 @@ -- | -- Return whether or not all elements viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal'--- satisfy a predicate, with access to the index @i@.+-- satisfy a predicate, with access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.allOf' is more flexible in what it accepts. --@@ -160,7 +161,7 @@ {-# INLINE iallOf #-} -- |--- Traverse the targets of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index @i@, discarding the results.+-- Traverse the targets of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the @i@, discarding the results. -- -- When you don't need access to the index then 'Control.Lens.Fold.traverseOf_' is more flexible in what it accepts. --@@ -360,8 +361,8 @@ -- 'itoListOf' :: 'Control.Lens.IndexedLens.SimpleIndexedLens' i s a -> s -> [(i,a)] -- 'itoListOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> s -> [(i,a)] -- @-itoListOf :: IndexedGetting i [(i,a)] s t a b -> s -> [(i,a)]-itoListOf l = ifoldMapOf l (\i a -> [(i,a)])+itoListOf :: IndexedGetting i (Endo [(i,a)]) s t a b -> s -> [(i,a)]+itoListOf l = ifoldrOf l (\i a -> ((i,a):)) [] {-# INLINE itoListOf #-} -------------------------------------------------------------------------------@@ -387,7 +388,7 @@ -- @ -- -- Change made to the indices will be discarded.-withIndicesOf :: Functor f => Overloaded (Index i) f s t a b -> LensLike f s t (i, a) (j, b)+withIndicesOf :: Functor f => Overloaded (Indexed i) f s t a b -> LensLike f s t (i, a) (j, b) withIndicesOf l f = withIndex l (\i c -> snd <$> f (i,c)) {-# INLINE withIndicesOf #-} @@ -398,7 +399,7 @@ -- 'indicesOf' :: 'SimpleIndexedLens' i s a -> 'Getter' s i -- 'indicesOf' :: 'SimpleIndexedTraversal' i s a -> 'Fold' s i -- @-indicesOf :: Gettable f => Overloaded (Index i) f s t a a -> LensLike f s t i j+indicesOf :: Gettable f => Overloaded (Indexed i) f s t a a -> LensLike f s t i j indicesOf l f = withIndex l (const . coerce . f) {-# INLINE indicesOf #-} @@ -411,31 +412,47 @@ -- When passed an 'Control.Lens.IndexedTraversal.IndexedTraversal', sadly the result is /not/ a legal 'Control.Lens.IndexedTraversal.IndexedTraversal'. -- -- See 'filtered' for a related counter-example.-ifiltering :: (Applicative f, Indexed i k) => (i -> a -> Bool) -> Index i (a -> f a) (s -> f t) -> k (a -> f a) (s -> f t)-ifiltering p l = index $ \ f -> withIndex l $ \ i c -> if p i c then f i c else pure c+ifiltering :: (Applicative f, Indexable i k)+ => (i -> a -> Bool)+ -> Indexed i (a -> f a) (s -> f t)+ -> k (a -> f a) (s -> f t)+ifiltering p l = indexed $ \ f ->+ withIndex l $ \ i c -> if p i c then f i c else pure c {-# INLINE ifiltering #-} --- | Reverse the order of the elements of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal'.--- This has no effect on an 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter', or 'Control.Lens.IndexedSetter.IndexedSetter'.-ibackwards :: Indexed i k => Index i (a -> (Backwards f) b) (s -> (Backwards f) t) -> k (a -> f b) (s -> f t)-ibackwards l = index $ \ f -> fmap forwards . withIndex l $ \ i -> backwards# (f i)+-- | Reverse the order of the elements of an 'IndexedFold' or+-- 'Control.Lens.IndexedTraversal.IndexedTraversal'.+-- This has no effect on an 'Control.Lens.IndexedLens.IndexedLens',+-- 'IndexedGetter', or 'Control.Lens.IndexedSetter.IndexedSetter'.+ibackwards :: Indexable i k+ => Indexed i (a -> (Backwards f) b) (s -> (Backwards f) t)+ -> k (a -> f b) (s -> f t)+ibackwards l = indexed $ \ f ->+ fmap forwards . withIndex l $ \ i -> backwards# (f i) {-# INLINE ibackwards #-} --- | Obtain an 'IndexedFold' by taking elements from another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' while a predicate holds.-itakingWhile :: (Gettable f, Applicative f, Indexed i k)- => (i -> a -> Bool)- -> IndexedGetting i (Endo (f s)) s s a a- -> k (a -> f a) (s -> f s)-itakingWhile p l = index $ \ f -> ifoldrOf l (\i a r -> if p i a then f i a *> r else noEffect) noEffect+-- | Obtain an 'IndexedFold' by taking elements from another+-- 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens',+-- 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal'+-- while a predicate holds.+itakingWhile :: (Gettable f, Applicative f, Indexable i k)+ => (i -> a -> Bool)+ -> IndexedGetting i (Endo (f s)) s s a a+ -> k (a -> f a) (s -> f s)+itakingWhile p l = indexed $ \ f ->+ ifoldrOf l (\i a r -> if p i a then f i a *> r else noEffect) noEffect {-# INLINE itakingWhile #-} -- | Obtain an 'IndexedFold' by dropping elements from another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' while a predicate holds.-idroppingWhile :: (Gettable f, Applicative f, Indexed i k)+idroppingWhile :: (Gettable f, Applicative f, Indexable i k) => (i -> a -> Bool) -> IndexedGetting i (Endo (f s, f s)) s s a a -> k (a -> f a) (s -> f s)-idroppingWhile p l = index $ \ f -> fst . ifoldrOf l (\i a r -> let s = f i a *> snd r in if p i a then (fst r, s) else (s, s)) (noEffect, noEffect)+idroppingWhile p l = indexed $ \ f ->+ fst . ifoldrOf l+ (\i a r -> let s = f i a *> snd r in if p i a then (fst r, s) else (s, s))+ (noEffect, noEffect) {-# INLINE idroppingWhile #-} ------------------------------------------------------------------------------@@ -443,4 +460,5 @@ ------------------------------------------------------------------------------ -- | Useful for storage.-newtype ReifiedIndexedFold i s a = ReifyIndexedFold { reflectIndexedFold :: IndexedFold i s a }+newtype ReifiedIndexedFold i s a =+ ReifyIndexedFold { reflectIndexedFold :: IndexedFold i s a }
src/Control/Lens/IndexedGetter.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- |@@ -12,25 +13,63 @@ ---------------------------------------------------------------------------- module Control.Lens.IndexedGetter (- -- * Indexed Folds+ -- * Indexed Getters IndexedGetter , IndexedGetting , ReifiedIndexedGetter(..)+ -- * Indexed Getter Combinators+ , iview, iviews+ , iuse, iuses ) where import Control.Lens.Indexed import Control.Lens.Internal+import Control.Lens.Internal.Combinators import Control.Lens.Classes+import Control.Monad.Reader+import Control.Monad.State ------------------------------------------------------------------------------ -- Indexed Getters ------------------------------------------------------------------------------ -- | Every 'IndexedGetter' is a valid 'Control.Lens.IndexedFold.IndexedFold' and 'Getter'.-type IndexedGetter i s a = forall k f. (Indexed i k, Gettable f) => k (a -> f a) (s -> f s)+type IndexedGetter i s a = forall k f. (Indexable i k, Gettable f) => k (a -> f a) (s -> f s) -- | Used to consume an 'Control.Lens.IndexedFold.IndexedFold'.-type IndexedGetting i m s t a b = Index i (a -> Accessor m b) (s -> Accessor m t)+type IndexedGetting i m s t a b = Indexed i (a -> Accessor m b) (s -> Accessor m t) -- | Useful for storage. newtype ReifiedIndexedGetter i s a = ReifyIndexedGetter { reflectIndexedGetter :: IndexedGetter i s a }++-- | View the index and value of an 'IndexedGetter' into the current environment as a pair.+--+-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of+-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted.+iview :: MonadReader s m => IndexedGetting i (i,a) s t a b -> m (i,a)+iview l = asks (runAccessor# (withIndex l (\i -> accessor# ((,) i))))+{-# INLINE iview #-}++-- | View a function of the index and value of an 'IndexedGetter' into the current environment+--+-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer.+--+-- @'iviews' ≡ 'Control.Lens.IndexedFold.ifoldMapOf'@+iviews :: MonadReader s m => IndexedGetting i r s t a b -> (i -> a -> r) -> m r+iviews l f = asks (runAccessor# (withIndex l (\i -> accessor# (f i))))+{-# INLINE iviews #-}++-- | Use the index and value of an 'IndexedGetter' into the current state as a pair.+--+-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of+-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted.+iuse :: MonadState s m => IndexedGetting i (i,a) s t a b -> m (i,a)+iuse l = gets (runAccessor# (withIndex l (\i -> accessor# ((,) i))))+{-# INLINE iuse #-}++-- | Use a function of the index and value of an 'IndexedGetter' into the current state.+--+-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer.+iuses :: MonadState s m => IndexedGetting i r s t a b -> (i -> a -> r) -> m r+iuses l f = gets (runAccessor# (withIndex l (\i -> accessor# (f i))))+{-# INLINE iuses #-}
src/Control/Lens/IndexedLens.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -27,10 +29,6 @@ ( -- * Indexed Lenses IndexedLens- -- * Common Indexed Lenses- , At(..)- , Contains(..)- , resultAt -- * Indexed Lens Combinators , (%%@~) , (<%@~)@@ -38,24 +36,25 @@ , (<%@=) -- * Storing Indexed Lenses , ReifiedIndexedLens(..)+ -- * Common Indexed Lenses+ , Contains(..)+ , resultAt -- * Simple , SimpleIndexedLens , SimpleReifiedIndexedLens ) where -import Control.Applicative-import Control.Lens.Indexed+import Control.Lens.Classes+import Control.Lens.Combinators+import Control.Lens.Internal import Control.Lens.Type import Control.Monad.State.Class as State import Data.Hashable-import Data.HashMap.Lazy as HashMap-import Data.IntMap as IntMap-import Data.Map as Map- import Data.HashSet as HashSet import Data.IntSet as IntSet import Data.Set as Set + -- $setup -- >>> import Control.Lens @@ -63,7 +62,7 @@ infix 4 %%@=, <%@= -- | Every 'IndexedLens' is a valid 'Lens' and a valid 'Control.Lens.IndexedTraversal.IndexedTraversal'.-type IndexedLens i s t a b = forall f k. (Indexed i k, Functor f) => k (a -> f b) (s -> f t)+type IndexedLens i s t a b = forall f k. (Indexable i k, Functor f) => k (a -> f b) (s -> f t) -- | @type 'SimpleIndexedLens' i = 'Simple' ('IndexedLens' i)@ type SimpleIndexedLens i s a = IndexedLens i s s a a@@ -72,7 +71,7 @@ -- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' and return a monoidal summary -- along with the answer. ----- @l '<%~' f = l '<%@~' 'const' f@+-- @l '<%~' f ≡ l '<%@~' 'const' f@ -- -- When you do not need access to the index then ('<%~') is more liberal in what it can accept. --@@ -82,7 +81,7 @@ -- ('<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (b, t) -- ('<%@~') :: 'Monoid' b => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (b, t) -- @-(<%@~) :: Overloaded (Index i) ((,)b) s t a b -> (i -> a -> b) -> s -> (b, t)+(<%@~) :: Overloaded (Indexed i) ((,)b) s t a b -> (i -> a -> b) -> s -> (b, t) l <%@~ f = withIndex l $ \i a -> let b = f i a in (b, b) {-# INLINE (<%@~) #-} @@ -90,7 +89,7 @@ -- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' and return a monoidal summary -- of the supplementary results and the answer. ----- @('%%@~') = 'withIndex'@+-- @('%%@~') ≡ 'withIndex'@ -- -- @ -- ('%%@~') :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t@@ -104,7 +103,7 @@ -- ('%%@~') :: 'IndexedLens' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- ('%%@~') :: 'Monoid' r => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- @-(%%@~) :: Overloaded (Index i) f s t a b -> (i -> a -> f b) -> s -> f t+(%%@~) :: Overloaded (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t (%%@~) = withIndex {-# INLINE (%%@~) #-} @@ -112,13 +111,13 @@ -- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' within the current state, and -- return a monoidal summary of the supplementary results. ----- @l '%%@=' f = 'state' (l '%%@~' f)@+-- @l '%%@=' f ≡ 'state' (l '%%@~' f)@ -- -- @ -- ('%%@=') :: 'MonadState' s m 'IndexedLens' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- ('%%@=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- @-(%%@=) :: MonadState s m => Overloaded (Index i) ((,)r) s s a b -> (i -> a -> (r, b)) -> m r+(%%@=) :: MonadState s m => Overloaded (Indexed i) ((,)r) s s a b -> (i -> a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,0) l %%@= f = State.state (l %%@~ f) #else@@ -137,37 +136,19 @@ -- ('<%@=') :: 'MonadState' s m 'IndexedLens' i s s a b -> (i -> a -> b) -> m b -- ('<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m b -- @-(<%@=) :: MonadState s m => Overloaded (Index i) ((,)b) s s a b -> (i -> a -> b) -> m b+(<%@=) :: MonadState s m => Overloaded (Indexed i) ((,)b) s s a b -> (i -> a -> b) -> m b l <%@= f = l %%@= \ i a -> let b = f i a in (b, b) {-# INLINE (<%@=) #-} --- | Provides an 'IndexedLens' that can be used to read, write or delete the value associated with a key in a map-like container.-class At k m | m -> k where- -- |- -- >>> Map.fromList [(1,"hello")] ^.at 1- -- Just "hello"- --- -- >>> at 1 ?~ "hello" $ Map.empty- -- fromList [(1,"hello")]- at :: k -> SimpleIndexedLens k (m v) (Maybe v)--instance At Int IntMap where- at k = index $ \ f m -> (`go` m) <$> f k (IntMap.lookup k m) where- go Nothing = IntMap.delete k- go (Just v') = IntMap.insert k v'- {-# INLINE at #-}+------------------------------------------------------------------------------+-- Reifying Indexed Lenses+------------------------------------------------------------------------------ -instance Ord k => At k (Map k) where- at k = index $ \ f m -> (`go` m) <$> f k (Map.lookup k m) where- go Nothing = Map.delete k- go (Just v') = Map.insert k v'- {-# INLINE at #-}+-- | Useful for storage.+newtype ReifiedIndexedLens i s t a b = ReifyIndexedLens { reflectIndexedLens :: IndexedLens i s t a b } -instance (Eq k, Hashable k) => At k (HashMap k) where- at k = index $ \ f m -> (`go` m) <$> f k (HashMap.lookup k m) where- go Nothing = HashMap.delete k- go (Just v') = HashMap.insert k v'- {-# INLINE at #-}+-- | @type 'SimpleIndexedLens' i = 'Simple' ('ReifiedIndexedLens' i)@+type SimpleReifiedIndexedLens i s a = ReifiedIndexedLens i s s a a -- | Provides an 'IndexedLens' that can be used to read, write or delete a member of a set-like container class Contains k m | m -> k where@@ -177,15 +158,18 @@ contains :: k -> SimpleIndexedLens k m Bool instance Contains Int IntSet where- contains k = index $ \ f s -> (\b -> if b then IntSet.insert k s else IntSet.delete k s) <$> f k (IntSet.member k s)+ contains k = indexed $ \ f s -> f k (IntSet.member k s) <&> \b ->+ if b then IntSet.insert k s else IntSet.delete k s {-# INLINE contains #-} instance Ord k => Contains k (Set k) where- contains k = index $ \ f s -> (\b -> if b then Set.insert k s else Set.delete k s) <$> f k (Set.member k s)+ contains k = indexed $ \ f s -> f k (Set.member k s) <&> \b ->+ if b then Set.insert k s else Set.delete k s {-# INLINE contains #-} instance (Eq k, Hashable k) => Contains k (HashSet k) where- contains k = index $ \ f s -> (\b -> if b then HashSet.insert k s else HashSet.delete k s) <$> f k (HashSet.member k s)+ contains k = indexed $ \ f s -> f k (HashSet.member k s) <&> \b ->+ if b then HashSet.insert k s else HashSet.delete k s {-# INLINE contains #-} -- | This lens can be used to change the result of a function but only where@@ -194,15 +178,5 @@ -- >>> let f = (+1) & resultAt 3 .~ 8 in (f 2, f 3) -- (3,8) resultAt :: Eq e => e -> SimpleIndexedLens e (e -> a) a-resultAt e = index $ \ g f -> (\a' e' -> if e == e' then a' else f e') <$> g e (f e)+resultAt e = indexed $ \ g f -> g e (f e) <&> \a' e' -> if e == e' then a' else f e' {-# INLINE resultAt #-}----------------------------------------------------------------------------------- Reifying Indexed Lenses----------------------------------------------------------------------------------- | Useful for storage.-newtype ReifiedIndexedLens i s t a b = ReifyIndexedLens { reflectIndexedLens :: IndexedLens i s t a b }---- | @type 'SimpleIndexedLens' i = 'Simple' ('ReifiedIndexedLens' i)@-type SimpleReifiedIndexedLens i s a = ReifiedIndexedLens i s s a a
src/Control/Lens/IndexedSetter.hs view
@@ -42,7 +42,8 @@ -- | Every 'IndexedSetter' is a valid 'Setter' -- -- The 'Control.Lens.Setter.Setter' laws are still required to hold.-type IndexedSetter i s t a b = forall f k. (Indexed i k, Settable f) => k (a -> f b) (s -> f t)+type IndexedSetter i s t a b = forall f k.+ (Indexable i k, Settable f) => k (a -> f b) (s -> f t) -- | -- @type 'SimpleIndexedSetter' i = 'Simple' ('IndexedSetter' i)@@@ -59,7 +60,7 @@ -- 'imapOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- 'imapOf' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @-imapOf :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t+imapOf :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t imapOf l f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE imapOf #-} @@ -74,7 +75,7 @@ -- 'iover' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- 'iover' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @-iover :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t+iover :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t iover l f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE iover #-} @@ -97,7 +98,7 @@ -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b-isets f = index $ \ g -> tainted# (f (\i -> untainted# (g i)))+isets f = indexed $ \ g -> tainted# (f (\i -> untainted# (g i))) {-# INLINE isets #-} -- | Adjust every target of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal'@@ -114,7 +115,7 @@ -- ('%@~') :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- ('%@~') :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @-(%@~) :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t+(%@~) :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t l %@~ f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE (%@~) #-} @@ -130,7 +131,7 @@ -- ('%@=') :: 'MonadState' s m => 'Control.Lens.IndexedLens.IndexedLens' i s s a b -> (i -> a -> b) -> m () -- ('%@=') :: 'MonadState' s m => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> m () -- @-(%@=) :: MonadState s m => Overloaded (Index i) Mutator s s a b -> (i -> a -> b) -> m ()+(%@=) :: MonadState s m => Overloaded (Indexed i) Mutator s s a b -> (i -> a -> b) -> m () l %@= f = State.modify (l %@~ f) {-# INLINE (%@=) #-} @@ -139,7 +140,8 @@ ------------------------------------------------------------------------------ -- | Useful for storage.-newtype ReifiedIndexedSetter i s t a b = ReifyIndexedSetter { reflectIndexedSetter :: IndexedSetter i s t a b }+newtype ReifiedIndexedSetter i s t a b =+ ReifyIndexedSetter { reflectIndexedSetter :: IndexedSetter i s t a b } -- | @type 'SimpleIndexedSetter' i = 'Simple' ('ReifiedIndexedSetter' i)@ type SimpleReifiedIndexedSetter i s a = ReifiedIndexedSetter i s s a a
src/Control/Lens/IndexedTraversal.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.IndexedTraversal@@ -30,10 +32,10 @@ IndexedTraversal -- * Common Indexed Traversals- , _at , iwhereOf , value , ignored+ , At(..) , TraverseMin(..) , TraverseMax(..) , traversed@@ -60,14 +62,17 @@ import Control.Applicative import Control.Applicative.Backwards+import Control.Lens.Combinators import Control.Lens.Indexed import Control.Lens.IndexedLens import Control.Lens.Internal import Control.Lens.Type import Control.Monad.Trans.State.Lazy as Lazy-import Data.Traversable+import Data.Hashable+import Data.HashMap.Lazy as HashMap import Data.IntMap as IntMap import Data.Map as Map+import Data.Traversable -- $setup -- >>> import Control.Lens@@ -76,12 +81,14 @@ -- Indexed Traversals ------------------------------------------------------------------------------ --- | Every indexed traversal is a valid 'Control.Lens.Traversal.Traversal' or 'Control.Lens.IndexedFold.IndexedFold'.+-- | Every indexed traversal is a valid 'Control.Lens.Traversal.Traversal' or+-- 'Control.Lens.IndexedFold.IndexedFold'. ----- The 'Indexed' constraint is used to allow an 'IndexedTraversal' to be used directly as a 'Control.Lens.Traversal.Traversal'.+-- The 'Indexed' constraint is used to allow an 'IndexedTraversal' to be used+-- directly as a 'Control.Lens.Traversal.Traversal'. -- -- The 'Control.Lens.Traversal.Traversal' laws are still required to hold.-type IndexedTraversal i s t a b = forall f k. (Indexed i k, Applicative f) => k (a -> f b) (s -> f t)+type IndexedTraversal i s t a b = forall f k. (Indexable i k, Applicative f) => k (a -> f b) (s -> f t) -- | @type 'SimpleIndexedTraversal' i = 'Simple' ('IndexedTraversal' i)@ type SimpleIndexedTraversal i s a = IndexedTraversal i s s a a@@ -100,7 +107,7 @@ -- 'itraverseOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t -- 'itraverseOf' :: 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t -- @-itraverseOf :: Overloaded (Index i) f s t a b -> (i -> a -> f b) -> s -> f t+itraverseOf :: Overloaded (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t itraverseOf = withIndex {-# INLINE itraverseOf #-} @@ -116,7 +123,7 @@ -- 'iforOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t -- 'iforOf' :: 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t -- @-iforOf :: Overloaded (Index i) f s t a b -> s -> (i -> a -> f b) -> f t+iforOf :: Overloaded (Indexed i) f s t a b -> s -> (i -> a -> f b) -> f t iforOf = flip . withIndex {-# INLINE iforOf #-} @@ -132,7 +139,7 @@ -- 'imapMOf' :: 'Monad' m => 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> m b) -> s -> m t -- 'imapMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> (i -> a -> m b) -> s -> m t -- @-imapMOf :: Overloaded (Index i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t+imapMOf :: Overloaded (Indexed i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t imapMOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i) {-# INLINE imapMOf #-} @@ -149,7 +156,7 @@ -- 'iforMOf' :: 'Monad' m => 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> s -> (i -> a -> m b) -> m t -- 'iforMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> s -> (i -> a -> m b) -> m t -- @-iforMOf :: Overloaded (Index i) (WrappedMonad m) s t a b -> s -> (i -> a -> m b) -> m t+iforMOf :: Overloaded (Indexed i) (WrappedMonad m) s t a b -> s -> (i -> a -> m b) -> m t iforMOf = flip . imapMOf {-# INLINE iforMOf #-} @@ -163,7 +170,7 @@ -- 'imapAccumROf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- 'imapAccumROf' :: 'IndexedTraversal' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- @-imapAccumROf :: Overloaded (Index i) (Lazy.State s) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t)+imapAccumROf :: Overloaded (Indexed i) (Lazy.State s) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) imapAccumROf l f s0 a = swap (Lazy.runState (withIndex l (\i c -> Lazy.state (\s -> swap (f i s c))) a) s0) {-# INLINE imapAccumROf #-} @@ -177,7 +184,7 @@ -- 'imapAccumLOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- 'imapAccumLOf' :: 'IndexedTraversal' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- @-imapAccumLOf :: Overloaded (Index i) (Backwards (Lazy.State s)) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t)+imapAccumLOf :: Overloaded (Indexed i) (Backwards (Lazy.State s)) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) imapAccumLOf l f s0 a = swap (Lazy.runState (forwards (withIndex l (\i c -> Backwards (Lazy.state (\s -> swap (f i s c)))) a)) s0) {-# INLINE imapAccumLOf #-} @@ -201,25 +208,19 @@ -- 'iwhereOf' :: 'SimpleIndexedTraversal' i s a -> (i -> 'Bool') -> 'SimpleIndexedTraversal' i s a -- 'iwhereOf' :: 'SimpleIndexedSetter' i s a -> (i -> 'Bool') -> 'SimpleIndexedSetter' i s a -- @-iwhereOf :: (Indexed i k, Applicative f) => Overloaded (Index i) f s t a a -> (i -> Bool) -> Overloaded k f s t a a-iwhereOf l p = index $ \f s -> withIndex l (\i a -> if p i then f i a else pure a) s+iwhereOf :: (Indexable i k, Applicative f) => Overloaded (Indexed i) f s t a a -> (i -> Bool) -> Overloaded k f s t a a+iwhereOf l p = indexed $ \f s -> withIndex l (\i a -> if p i then f i a else pure a) s {-# INLINE iwhereOf #-} --- | This simple indexed traversal lets you 'traverse' the value at a given key in a map.------ @'_at' k = 'at' k '<.' 'traverse'@-_at :: At k m => k -> SimpleIndexedTraversal k (m v) v-_at k = at k <. traverse-{-# INLINE _at #-}- -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b-traversed = indexed traverse+traversed = indexing traverse+{-# INLINE traversed #-} -- | This provides a 'Traversal' that checks a predicate on a key before -- allowing you to traverse into a value. value :: (k -> Bool) -> SimpleIndexedTraversal k (k, v) v-value p = index $ \ f kv@(k,v) -> if p k then (,) k <$> f k v else pure kv+value p = indexed $ \ f kv@(k,v) -> if p k then (,) k <$> f k v else pure kv {-# INLINE value #-} -- | This is the trivial empty traversal.@@ -227,28 +228,88 @@ -- @'ignored' :: 'IndexedTraversal' i s s a b@ -- -- @'ignored' ≡ 'const' 'pure'@-ignored :: forall k f i s a b. (Indexed i k, Applicative f) => Overloaded k f s s a b-ignored = index $ \ (_ :: i -> a -> f b) s -> pure s :: f s+ignored :: forall k f i s a b. (Indexable i k, Applicative f) => Overloaded k f s s a b+ignored = indexed $ \ (_ :: i -> a -> f b) s -> pure s :: f s {-# INLINE ignored #-} +-- | 'At' provides a lens that can be used to read,+-- write or delete the value associated with a key in a map-like+-- container on an ad hoc basis.+class At k m | m -> k where+ -- |+ -- >>> Map.fromList [(1,"hello")] ^.at 1+ -- Just "hello"+ --+ -- >>> at 1 ?~ "hello" $ Map.empty+ -- fromList [(1,"hello")]+ --+ -- Note: 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where+ -- you cannot satisfy the 'Lens' laws.+ at :: k -> SimpleIndexedLens k (m v) (Maybe v)++ -- | This simple indexed traversal lets you 'traverse' the value at a given key in a map.+ --+ -- *NB:* _setting_ the value of this lens will only set the value in the lens+ -- if it is already present.+ --+ -- @'_at' k ≡ 'at' k '<.' 'traverse'@+ _at :: k -> SimpleIndexedTraversal k (m v) v+ _at k = at k <. traverse++instance At Int IntMap where+ at k = indexed $ \f m ->+ let mv = IntMap.lookup k m+ go Nothing = maybe m (const (IntMap.delete k m)) mv+ go (Just v') = IntMap.insert k v' m+ in go <$> f k mv where+ {-# INLINE at #-}+ _at k = indexed $ \f m -> case IntMap.lookup k m of+ Just v -> f k v <&> \v' -> IntMap.insert k v' m+ Nothing -> pure m+ {-# INLINE _at #-}++instance Ord k => At k (Map k) where+ at k = indexed $ \f m ->+ let mv = Map.lookup k m+ go Nothing = maybe m (const (Map.delete k m)) mv+ go (Just v') = Map.insert k v' m+ in go <$> f k mv+ {-# INLINE at #-}+ _at k = indexed $ \f m -> case Map.lookup k m of+ Just v -> f k v <&> \v' -> Map.insert k v' m+ Nothing -> pure m+ {-# INLINE _at #-}++instance (Eq k, Hashable k) => At k (HashMap k) where+ at k = indexed $ \f m ->+ let mv = HashMap.lookup k m+ go Nothing = maybe m (const (HashMap.delete k m)) mv+ go (Just v') = HashMap.insert k v' m+ in go <$> f k mv+ {-# INLINE at #-}+ _at k = indexed $ \f m -> case HashMap.lookup k m of+ Just v -> f k v <&> \v' -> HashMap.insert k v' m+ Nothing -> pure m+ {-# INLINE _at #-}+ -- | Allows 'IndexedTraversal' the value at the smallest index. class Ord k => TraverseMin k m | m -> k where -- | 'IndexedTraversal' of the element with the smallest index. traverseMin :: SimpleIndexedTraversal k (m v) v instance TraverseMin Int IntMap where- traverseMin = index $ \f m -> case IntMap.minViewWithKey m of+ traverseMin = indexed $ \f m -> case IntMap.minViewWithKey m of #if MIN_VERSION_containers(0,5,0)- Just ((k,a), _) -> (\v -> IntMap.updateMin (const (Just v)) m) <$> f k a+ Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMin (const (Just v)) m #else- Just ((k,a), _) -> (\v -> IntMap.updateMin (const v) m) <$> f k a+ Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMin (const v) m #endif Nothing -> pure m {-# INLINE traverseMin #-} instance Ord k => TraverseMin k (Map k) where- traverseMin = index $ \f m -> case Map.minViewWithKey m of- Just ((k, a), _) -> (\v -> Map.updateMin (const (Just v)) m) <$> f k a+ traverseMin = indexed $ \f m -> case Map.minViewWithKey m of+ Just ((k, a), _) -> f k a <&> \v -> Map.updateMin (const (Just v)) m Nothing -> pure m {-# INLINE traverseMin #-} @@ -258,22 +319,23 @@ traverseMax :: SimpleIndexedTraversal k (m v) v instance TraverseMax Int IntMap where- traverseMax = index $ \f m -> case IntMap.maxViewWithKey m of+ traverseMax = indexed $ \f m -> case IntMap.maxViewWithKey m of #if MIN_VERSION_containers(0,5,0)- Just ((k,a), _) -> (\v -> IntMap.updateMax (const (Just v)) m) <$> f k a+ Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMax (const (Just v)) m #else- Just ((k,a), _) -> (\v -> IntMap.updateMax (const v) m) <$> f k a+ Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMax (const v) m #endif Nothing -> pure m {-# INLINE traverseMax #-} instance Ord k => TraverseMax k (Map k) where- traverseMax = index $ \f m -> case Map.maxViewWithKey m of- Just ((k, a), _) -> (\v -> Map.updateMax (const (Just v)) m) <$> f k a+ traverseMax = indexed $ \f m -> case Map.maxViewWithKey m of+ Just ((k, a), _) -> f k a <&> \v -> Map.updateMax (const (Just v)) m Nothing -> pure m {-# INLINE traverseMax #-} --- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or 'Control.Lens.Iso.Iso' if it exists.+-- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or+-- 'Control.Lens.Iso.Iso' if it exists. -- -- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 -- [[1],[5,4]]@@ -291,8 +353,11 @@ -- 'elementOf' :: 'Simple' 'Traversal' s a -> Int -> 'SimpleIndexedTraversal' 'Int' s a -- 'elementOf' :: 'Fold' s a -> Int -> 'IndexedFold' 'Int' s a -- @-elementOf :: (Applicative f, Indexed Int k) => LensLike (Indexing f) s t a a -> Int -> Overloaded k f s t a a-elementOf l = elementsOf l . (==)+elementOf :: (Applicative f, Indexable Int k)+ => LensLike (Indexing f) s t a a+ -> Int+ -> Overloaded k f s t a a+elementOf l p = elementsOf l (p ==) {-# INLINE elementOf #-} -- | Traverse the /nth/ element of a 'Traversable' container.@@ -308,9 +373,13 @@ -- 'elementsOf' :: 'Simple' 'Traversal' s a -> ('Int' -> 'Bool') -> 'SimpleIndexedTraversal' 'Int' s a -- 'elementsOf' :: 'Fold' s a -> ('Int' -> 'Bool') -> 'IndexedFold' 'Int' s a -- @-elementsOf :: (Applicative f, Indexed Int k) => LensLike (Indexing f) s t a a -> (Int -> Bool) -> Overloaded k f s t a a-elementsOf l p = index $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> (if p i then iafb i a else pure a, i + 1))) s) 0 of- (r, _) -> r+elementsOf :: (Applicative f, Indexable Int k)+ => LensLike (Indexing f) s t a a+ -> (Int -> Bool)+ -> Overloaded k f s t a a+elementsOf l p = indexed $ \iafb s ->+ case runIndexing (l (\a -> Indexing (\i -> i `seq` (if p i then iafb i a else pure a, i + 1))) s) 0 of+ (r, _) -> r {-# INLINE elementsOf #-} -- | Traverse elements of a 'Traversable' container where their ordinal positions matches a predicate.@@ -325,7 +394,8 @@ ------------------------------------------------------------------------------ -- | Useful for storage.-newtype ReifiedIndexedTraversal i s t a b = ReifyIndexedTraversal { reflectIndexedTraversal :: IndexedTraversal i s t a b }+newtype ReifiedIndexedTraversal i s t a b =+ ReifyIndexedTraversal { reflectIndexedTraversal :: IndexedTraversal i s t a b } -- | @type 'SimpleIndexedTraversal' i = 'Simple' ('ReifiedIndexedTraversal' i)@ type SimpleReifiedIndexedTraversal i s a = ReifiedIndexedTraversal i s s a a
src/Control/Lens/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-}@@ -6,9 +7,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MagicHash #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -50,21 +50,33 @@ , Max(..), getMax , Min(..), getMin , Indexing(..)+ -- * Overloadings+ , Prismoid(..)+ , Isoid(..)+ , Indexed(..)+ , CoA, CoB ) where import Control.Applicative import Control.Category import Control.Comonad import Control.Comonad.Store.Class-import Control.Lens.Isomorphic import Control.Lens.Classes import Control.Monad import Prelude hiding ((.),id) import Data.Functor.Compose import Data.Functor.Identity import Data.Monoid+#ifndef SAFE import Unsafe.Coerce+#endif +#ifndef SAFE+#define UNSAFELY(x) unsafeCoerce+#else+#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))+#endif+ ----------------------------------------------------------------------------- -- Functors -----------------------------------------------------------------------------@@ -316,8 +328,10 @@ coerce (Effect m) = Effect m instance Monad m => Effective m r (Effect m r) where- effective = isomorphic Effect getEffect+ effective = Effect {-# INLINE effective #-}+ ineffective = getEffect+ {-# INLINE ineffective #-} -- | Wrap a monadic effect with a phantom type argument. Used when magnifying RWST. newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) }@@ -372,8 +386,10 @@ coerce (Accessor m) = Accessor m instance Effective Identity r (Accessor r) where- effective = isomorphic (Accessor . runIdentity) (Identity . runAccessor)+ effective = Accessor . runIdentity {-# INLINE effective #-}+ ineffective = Identity . runAccessor+ {-# INLINE ineffective #-} -- | A 'Monoid' for a 'Gettable' 'Applicative'. newtype Folding f a = Folding { getFolding :: f a }@@ -396,16 +412,19 @@ instance Functor Mutator where fmap f (Mutator a) = Mutator (f a)+ {-# INLINE fmap #-} instance Applicative Mutator where pure = Mutator+ {-# INLINE pure #-} Mutator f <*> Mutator a = Mutator (f a)+ {-# INLINE (<*>) #-} instance Settable Mutator where untainted = runMutator- untainted# = unsafeCoerce+ untainted# = UNSAFELY(runMutator) {-# INLINE untainted #-}- tainted# = unsafeCoerce+ tainted# = UNSAFELY(Mutator) {-# INLINE tainted# #-} -- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Gettable' instance@@ -453,3 +472,79 @@ sellT i = BazaarT (\k -> k i) {-# INLINE sellT #-} +------------------------------------------------------------------------------+-- Prism Internals+------------------------------------------------------------------------------++type family ArgOf (f_b :: *) :: *+type instance ArgOf (f b) = b++-- | Extract @a@ from the type @a -> f b@+type family CoA x :: *++-- | Extract @b@ from the type @a -> f b@+type family CoB x :: *+type instance CoA (a -> f_b) = a+type instance CoB (a -> f_b) = ArgOf f_b++-- | This data type is used to capture all of the information provided by the+-- 'Prismatic' -- class, so you can turn a 'Prism' around into a 'Getter' or+-- otherwise muck around with its internals.+--+-- If you see a function that expects a 'Prismoid' or 'APrism', it is probably+-- just expecting a 'Prism'.+data Prismoid ab st where+ Prismoid :: Prismoid x x+ Prism :: (CoB x -> CoB y) -> (CoA y -> Either (CoB y) (CoA x)) -> Prismoid x y++instance Category Prismoid where+ id = Prismoid+ x . Prismoid = x+ Prismoid . x = x+ Prism ty xeys . Prism bt seta = Prism (ty.bt) $ \x ->+ case xeys x of+ Left y -> Left y+ Right s -> case seta s of+ Left t -> Left (ty t)+ Right a -> Right a++instance Isomorphic Prismoid where+ iso sa bt = Prism bt (Right . sa)+ {-# INLINE iso #-}++instance Prismatic Prismoid where+ prism = Prism+ {-# INLINE prism #-}++------------------------------------------------------------------------------+-- Isomorphism Internals+------------------------------------------------------------------------------++-- | Reify all of the information given to you by being 'Isomorphic'.+data Isoid ab st where+ Isoid :: Isoid ab ab+ Iso :: (CoA y -> CoA x) -> (CoB x -> CoB y) -> Isoid x y++instance Category Isoid where+ id = Isoid+ Isoid . x = x+ x . Isoid = x+ Iso xs ty . Iso sa bt = Iso (sa.xs) (ty.bt)++instance Isomorphic Isoid where+ iso = Iso+ {-# INLINE iso #-}++------------------------------------------------------------------------------+-- Indexed Internals+------------------------------------------------------------------------------++-- | A function with access to a index. This constructor may be useful when you need to store+-- a 'Indexable' in a container to avoid @ImpredicativeTypes@.+newtype Indexed i a b = Indexed { withIndex :: (i -> a) -> b }++-- | Using an equality witness to avoid potential overlapping instances+-- and aid dispatch.+instance i ~ j => Indexable i (Indexed j) where+ indexed = Indexed+ {-# INLINE indexed #-}
src/Control/Lens/Internal/Combinators.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#if defined(TRUSTWORTHY) && !defined(SAFE) {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -58,166 +58,174 @@ import Control.Applicative.Backwards import Control.Lens.Internal import Data.Monoid+#ifndef SAFE import Unsafe.Coerce+#endif +#ifndef SAFE+#define UNSAFELY(x) unsafeCoerce+#else+#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))+#endif+ const# :: (a -> b) -> a -> Const b r-const# = unsafeCoerce+const# = UNSAFELY(Const) getConst# :: (a -> Const b r) -> a -> b-getConst# = unsafeCoerce+getConst# = UNSAFELY(getConst) zipList# :: (a -> [b]) -> a -> ZipList b-zipList# = unsafeCoerce+zipList# = UNSAFELY(ZipList) getZipList# :: (a -> ZipList b) -> a -> [b]-getZipList# = unsafeCoerce+getZipList# = UNSAFELY(getZipList) wrapMonad# :: (a -> m b) -> a -> WrappedMonad m b-wrapMonad# = unsafeCoerce+wrapMonad# = UNSAFELY(WrapMonad) unwrapMonad# :: (a -> WrappedMonad m b) -> a -> m b-unwrapMonad# = unsafeCoerce+unwrapMonad# = UNSAFELY(unwrapMonad) last# :: (a -> Maybe b) -> a -> Last b-last# = unsafeCoerce+last# = UNSAFELY(Last) getLast# :: (a -> Last b) -> a -> Maybe b-getLast# = unsafeCoerce+getLast# = UNSAFELY(getLast) first# :: (a -> Maybe b) -> a -> First b-first# = unsafeCoerce+first# = UNSAFELY(First) getFirst# :: (a -> First b) -> a -> Maybe b-getFirst# = unsafeCoerce+getFirst# = UNSAFELY(getFirst) product# :: (a -> b) -> a -> Product b-product# = unsafeCoerce+product# = UNSAFELY(Product) getProduct# :: (a -> Product b) -> a -> b-getProduct# = unsafeCoerce+getProduct# = UNSAFELY(getProduct) sum# :: (a -> b) -> a -> Sum b-sum# = unsafeCoerce+sum# = UNSAFELY(Sum) getSum# :: (a -> Sum b) -> a -> b-getSum# = unsafeCoerce+getSum# = UNSAFELY(getSum) any# :: (a -> Bool) -> a -> Any-any# = unsafeCoerce+any# = UNSAFELY(Any) getAny# :: (a -> Any) -> a -> Bool-getAny# = unsafeCoerce+getAny# = UNSAFELY(getAny) all# :: (a -> Bool) -> a -> All-all# = unsafeCoerce+all# = UNSAFELY(All) getAll# :: (a -> All) -> a -> Bool-getAll# = unsafeCoerce+getAll# = UNSAFELY(getAll) dual# :: (a -> b) -> a -> Dual b-dual# = unsafeCoerce+dual# = UNSAFELY(Dual) getDual# :: (a -> Dual b) -> a -> b-getDual# = unsafeCoerce+getDual# = UNSAFELY(getDual) endo# :: (a -> b -> b) -> a -> Endo b-endo# = unsafeCoerce+endo# = UNSAFELY(Endo) appEndo# :: (a -> Endo b) -> a -> b -> b-appEndo# = unsafeCoerce+appEndo# = UNSAFELY(appEndo) may# :: (a -> Maybe b) -> a -> May b-may# = unsafeCoerce+may# = UNSAFELY(May) getMay# :: (a -> May b) -> a -> Maybe b-getMay# = unsafeCoerce+getMay# = UNSAFELY(getMay) folding# :: (a -> f b) -> a -> Folding f b-folding# = unsafeCoerce+folding# = UNSAFELY(Folding) getFolding# :: (a -> Folding f b) -> a -> f b-getFolding# = unsafeCoerce+getFolding# = UNSAFELY(getFolding) effect# :: (a -> m r) -> a -> Effect m r b-effect# = unsafeCoerce+effect# = UNSAFELY(Effect) getEffect# :: (a -> Effect m r b) -> a -> m r-getEffect# = unsafeCoerce+getEffect# = UNSAFELY(getEffect) effectRWS# :: (a -> st -> m (s, st, w)) -> a -> EffectRWS w st m s b-effectRWS# = unsafeCoerce+effectRWS# = UNSAFELY(EffectRWS) getEffectRWS# :: (a -> EffectRWS w st m s b) -> a -> st -> m (s, st, w)-getEffectRWS# = unsafeCoerce+getEffectRWS# = UNSAFELY(getEffectRWS) accessor# :: (a -> r) -> a -> Accessor r b-accessor# = unsafeCoerce+accessor# = UNSAFELY(Accessor) runAccessor# :: (a -> Accessor r b) -> a -> r-runAccessor# = unsafeCoerce+runAccessor# = UNSAFELY(runAccessor) err# :: (a -> Either e b) -> a -> Err e b-err# = unsafeCoerce+err# = UNSAFELY(Err) getErr# :: (a -> Err e b) -> a -> Either e b-getErr# = unsafeCoerce+getErr# = UNSAFELY(getErr) traversed# :: (a -> f ()) -> a -> Traversed f-traversed# = unsafeCoerce+traversed# = UNSAFELY(Traversed) getTraversed# :: (a -> Traversed f) -> a -> f ()-getTraversed# = unsafeCoerce+getTraversed# = UNSAFELY(getTraversed) sequenced# :: (a -> f ()) -> a -> Sequenced f-sequenced# = unsafeCoerce+sequenced# = UNSAFELY(Sequenced) getSequenced# :: (a -> Sequenced f) -> a -> f ()-getSequenced# = unsafeCoerce+getSequenced# = UNSAFELY(getSequenced) focusing# :: (a -> m (s, b)) -> a -> Focusing m s b-focusing# = unsafeCoerce+focusing# = UNSAFELY(Focusing) unfocusing# :: (a -> Focusing m s b) -> a -> m (s, b)-unfocusing# = unsafeCoerce+unfocusing# = UNSAFELY(unfocusing) focusingWith# :: (a -> m (s, b, w)) -> a -> FocusingWith w m s b-focusingWith# = unsafeCoerce+focusingWith# = UNSAFELY(FocusingWith) unfocusingWith# :: (a -> FocusingWith w m s b) -> a -> m (s, b, w)-unfocusingWith# = unsafeCoerce+unfocusingWith# = UNSAFELY(unfocusingWith) focusingPlus# :: (a -> k (s, w) b) -> a -> FocusingPlus w k s b-focusingPlus# = unsafeCoerce+focusingPlus# = UNSAFELY(FocusingPlus) unfocusingPlus# :: (a -> FocusingPlus w k s b) -> a -> k (s, w) b-unfocusingPlus# = unsafeCoerce+unfocusingPlus# = UNSAFELY(unfocusingPlus) focusingOn# :: (a -> k (f s) b) -> a -> FocusingOn f k s b-focusingOn# = unsafeCoerce+focusingOn# = UNSAFELY(FocusingOn) unfocusingOn# :: (a -> FocusingOn f k s b) -> a -> k (f s) b-unfocusingOn# = unsafeCoerce+unfocusingOn# = UNSAFELY(unfocusingOn) focusingMay# :: (a -> k (May s) b) -> a -> FocusingMay k s b-focusingMay# = unsafeCoerce+focusingMay# = UNSAFELY(FocusingMay) unfocusingMay# :: (a -> FocusingMay k s b) -> a -> k (May s) b-unfocusingMay# = unsafeCoerce+unfocusingMay# = UNSAFELY(unfocusingMay) focusingErr# :: (a -> k (Err e s) b) -> a -> FocusingErr e k s b-focusingErr# = unsafeCoerce+focusingErr# = UNSAFELY(FocusingErr) unfocusingErr# :: (a -> FocusingErr e k s b) -> a -> k (Err e s) b-unfocusingErr# = unsafeCoerce+unfocusingErr# = UNSAFELY(unfocusingErr) mutator# :: (a -> b) -> a -> Mutator b-mutator# = unsafeCoerce+mutator# = UNSAFELY(Mutator) runMutator# :: (a -> Mutator b) -> a -> b-runMutator# = unsafeCoerce+runMutator# = UNSAFELY(runMutator) backwards# :: (a -> f b) -> a -> Backwards f b-backwards# = unsafeCoerce+backwards# = UNSAFELY(Backwards) forwards# :: (a -> Backwards f b) -> a -> f b-forwards# = unsafeCoerce+forwards# = UNSAFELY(forwards)
src/Control/Lens/Internal/Zipper.hs view
@@ -16,30 +16,29 @@ -- Portability : non-portable -- -- This module provides internal types and functions used in the implementation--- of Control.Lens.Zipper. You shouldn't need to import it directly, and the--- exported types can be used to break Zipper invariants.+-- of @Control.Lens.Zipper@. You shouldn't need to import it directly, and the+-- exported types can be used to break 'Zipper' invariants. -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Zipper where import Control.Applicative-import Control.Applicative.Backwards import Control.Category-import Control.Comonad-import Control.Comonad.Store.Class-import Control.Monad ((>=>))-import Control.Lens.Fold-import Control.Lens.Indexed+import Control.Monad+import Control.Lens.Classes+import Control.Lens.Getter import Control.Lens.IndexedLens import Control.Lens.Internal+import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type-import Data.Foldable-import Data.List.NonEmpty as NonEmpty import Data.Maybe-import Data.Monoid import Prelude hiding ((.),id) +-- $setup+-- >>> import Control.Lens+-- >>> import Data.Char+ ----------------------------------------------------------------------------- -- * Zippers -----------------------------------------------------------------------------@@ -48,12 +47,12 @@ -- -- Every 'Zipper' starts with 'Top'. ----- /e.g./ @'Top' ':>' a@ is the trivial zipper.+-- /e.g./ @'Top' ':>' a@ is the type of the trivial 'Zipper'. data Top infixl 9 :> --- | This is the type of a 'Zipper'. It visually resembes a 'breadcrumb trail' as+-- | This is the type of a 'Zipper'. It visually resembles a \"breadcrumb trail\" as -- used in website navigation. Each breadcrumb in the trail represents a level you -- can move up to. --@@ -63,63 +62,172 @@ -- -- to represent a zipper from @('String','Double')@ down to 'Char' that has an intermediate -- crumb for the 'String' containing the 'Char'.-data p :> a = Zipper (Coil p a) {-# UNPACK #-} !(Level a)+--+-- You can construct a zipper into *any* data structure with 'zipper'.+--+-- >>> :t zipper (Just "hello")+-- zipper (Just "hello") :: Top :> Maybe [Char]+--+-- You can repackage up the contents of a zipper with 'rezip'.+--+-- >>> rezip $ zipper 42+-- 42+--+-- The combinators in this module provide lot of things you can do to the zipper while you+-- have it open.+--+-- Note that a value of type @h ':>' s ':>' a@ doesn't actually contain a value+-- of type @h ':>' s@ -- as we descend into a level, the previous level is+-- unpacked and stored in 'Coil' form. Only one value of type @_ ':>' _@ exists+-- at any particular time for any particular 'Zipper'.+data h :> a = Zipper (Coil h a) -- The 'Coil' storing the previous levels of the 'Zipper'.+ {-# UNPACK #-} !Int -- Number of items to the left.+ [a] -- Items to the left (stored reversed).+ a -- Focused item.+ [a] -- Items to the right. --- | This represents the type a zipper will have when it is fully 'Zipped' back up.+-- | This is an alias for '(:>)'. Provided mostly for convenience+type Zipper = (:>)++-- | This represents the type a 'Zipper' will have when it is fully 'Zipped' back up. type family Zipped h a type instance Zipped Top a = a-type instance Zipped (h :> b) a = Zipped h b+type instance Zipped (h :> s) a = Zipped h s --- | 'Coil' is used internally in the definition of a 'Zipper'.+-- | A 'Coil' is a linked list of the levels above the current one. The length+-- of a 'Coil' is known at compile time.+--+-- This is part of the internal structure of a zipper. You shouldn't need to manipulate this directly. data Coil :: * -> * -> * where Coil :: Coil Top a- Snoc :: Coil h b ->- {-# UNPACK #-} !Int ->- SimpleLensLike (Bazaar a a) b a ->- [b] -> (NonEmpty a -> b) -> [b] ->- Coil (h :> b) a+ Snoc :: Coil h s -- Previous 'Coil'.+ -> SimpleLensLike (Bazaar a a) s a -- The 'Traversal' used to descend into this level (used to build a 'Tape').+ -- The Zipper above us, unpacked:+ -> {-# UNPACK #-} !Int -- Number of items to the left.+ -> [s] -- Previous level's items to the left (stored reverse).+ -> ([a] -> s) -- Function to rebuild the previous level's focused item from the entire current level.+ -- (Since the current level always has a focus, the list must be nonempty.)+ -> [s] -- Previous level's items to the right.+ -> Coil (h :> s) a --- | This 'Lens' views the current target of the 'zipper'.+-- | This 'Lens' views the current target of the 'Zipper'.+--+-- A 'Tape' that can be used to get to the current location is available as the index of this 'Lens'. focus :: SimpleIndexedLens (Tape (h :> a)) (h :> a) a-focus = index $ \f (Zipper h (Level n l a r)) -> (\a' -> Zipper h (Level n l a' r)) <$> f (Tape (peel h) n) a+focus = indexed $ \f (Zipper h n l a r) -> (\a' -> Zipper h n l a' r) <$> f (Tape (peel h) n) a {-# INLINE focus #-} --- | Construct a 'zipper' that can explore anything.+-- | Construct a 'Zipper' that can explore anything, and start it at the top. zipper :: a -> Top :> a-zipper a = Zipper Coil (Level 0 [] a [])+zipper a = Zipper Coil 0 [] a [] {-# INLINE zipper #-} --- | Return the index into the current 'Traversal' within the current level of the zipper.+-- | Return the index into the current 'Traversal' within the current level of the 'Zipper'. -- -- @'jerkTo' ('tooth' l) l = Just'@-tooth :: (a :> b) -> Int-tooth (Zipper _ (Level n _ _ _)) = n+--+-- Mnemonically, zippers have a number of 'teeth' within each level. This is which 'tooth' you are currently at.+tooth :: (h :> a) -> Int+tooth (Zipper _ n _ _ _) = n {-# INLINE tooth #-} --- | Move the 'zipper' 'up', closing the current level and focusing on the parent element.-up :: (a :> b :> c) -> a :> b-up (Zipper (Snoc h n _ ls k rs) w) = Zipper h (Level n ls (k (rezipLevel w)) rs)-{-# INLINE up #-}+-- | Move the 'Zipper' 'upward', closing the current level and focusing on the parent element.+--+-- NB: Attempts to move upward from the 'Top' of the 'Zipper' will fail to typecheck.+--+-- >>> :t zipper ("hello","world") & downward _1 & fromWithin traverse & upward+-- zipper ("hello","world") & downward _1 & fromWithin traverse & upward+-- :: (Top :> ([Char], [Char])) :> [Char]+upward :: (h :> s :> a) -> h :> s+upward (Zipper (Snoc h _ un uls k urs) _ ls x rs) = Zipper h un uls ux urs+ where ux = k (reverseList ls ++ x : rs)+{-# INLINE upward #-} --- | Pull the 'zipper' 'left' within the current 'Traversal'.-left :: (a :> b) -> Maybe (a :> b)-left (Zipper h w) = Zipper h <$> leftLevel w-{-# INLINE left #-}+-- | Jerk the 'Zipper' one 'tooth' to the 'rightward' within the current 'Lens' or 'Traversal'.+--+-- Attempts to move past the start of the current 'Traversal' (or trivially, the current 'Lens')+-- will return 'Nothing'.+--+-- >>> isNothing $ zipper "hello" & rightward+-- True+--+-- >>> zipper "hello" & fromWithin traverse & rightward <&> view focus+-- 'e'+--+-- >>> zipper "hello" & fromWithin traverse & rightward <&> focus .~ 'u' <&> rezip+-- "hullo"+--+-- >>> rezip $ zipper (1,2) & fromWithin both & tug rightward & focus .~ 3+-- (1,3)+rightward :: MonadPlus m => (h :> a) -> m (h :> a)+rightward (Zipper _ _ _ _ [] ) = mzero+rightward (Zipper h n ls a (r:rs)) = return (Zipper h (n + 1) (a:ls) r rs)+{-# INLINE rightward #-} --- | Pull the entry one entry to the 'right'-right :: (a :> b) -> Maybe (a :> b)-right (Zipper h w) = Zipper h <$> rightLevel w-{-# INLINE right #-}+-- | Jerk the 'zipper' 'leftward' one 'tooth' within the current 'Lens' or 'Traversal'.+--+-- Attempts to move past the end of the current 'Traversal' (or trivially, the current 'Lens')+-- will return 'Nothing'.+--+-- >>> isNothing $ zipper "hello" & leftward+-- True --- | This allows you to safely 'tug left' or 'tug right' on a 'zipper'.+-- >>> isNothing $ zipper "hello" & within traverse >>= leftward+-- True --+-- >>> zipper "hello" & within traverse <&> tug leftward+-- Just 'h'+--+-- >>> zipper "hello" & fromWithin traverse & tug rightward & tug leftward & view focus+-- 'h'+leftward :: MonadPlus m => (h :> a) -> m (h :> a)+leftward (Zipper _ _ [] _ _ ) = mzero+leftward (Zipper h n (l:ls) a rs) = return (Zipper h (n - 1) ls l (a:rs))+{-# INLINE leftward #-}++-- | Move to the leftmost position of the current 'Traversal'.+--+-- This is just a convenient alias for @'farthest' 'leftward'@.+--+-- >>> zipper "hello" & fromWithin traverse & rightmost & focus .~ 'a' & rezip+-- "hella"+leftmost :: (a :> b) -> a :> b+leftmost = farthest leftward++-- | Move to the rightmost position of the current 'Traversal'.+--+-- This is just a convenient alias for @'farthest' 'rightward'@.+--+-- >>> zipper "hello" & fromWithin traverse & rightmost & focus .~ 'y' & leftmost & focus .~ 'j' & rezip+-- "jelly"+rightmost :: (a :> b) -> a :> b+rightmost = farthest rightward++-- | This allows you to safely 'tug leftward' or 'tug rightward' on a 'zipper'. This+-- will attempt the move, and stay where it was if it fails.+-- -- The more general signature allows its use in other circumstances, however.+--+-- @'tug' f x ≡ 'fromMaybe' a (f a)@+--+-- >>> fmap rezip $ zipper "hello" & within traverse <&> tug leftward <&> focus .~ 'j'+-- "jello"+--+-- >>> fmap rezip $ zipper "hello" & within traverse <&> tug rightward <&> focus .~ 'u'+-- "hullo" tug :: (a -> Maybe a) -> a -> a tug f a = fromMaybe a (f a) {-# INLINE tug #-} --- | This allows you to safely 'tug left' or 'tug right' on a 'zipper', moving multiple steps in a given direction,--- stopping at the last place you couldn't move from.+-- | This allows you to safely @'tug' 'leftward'@ or @'tug' 'rightward'@ multiple times on a 'zipper',+-- moving multiple steps in a given direction and stopping at the last place you+-- couldn't move from. This lets you safely move a zipper, because it will stop at either end.+--+-- >>> fmap rezip $ zipper "stale" & within traverse <&> tugs rightward 2 <&> focus .~ 'y'+-- "style"+--+-- >>> rezip $ zipper "want" & fromWithin traverse & tugs rightward 2 & focus .~ 'r' & tugs leftward 100 & focus .~ 'c'+-- "cart" tugs :: (a -> Maybe a) -> Int -> a -> a tugs f n0 | n0 < 0 = error "tugs: negative tug count"@@ -129,19 +237,33 @@ go n a = maybe a (go (n - 1)) (f a) {-# INLINE tugs #-} --- | Move in a direction as far as you can go, then stop.+-- | Move in a direction as far as you can go, then stop there.+--+-- This repeatedly applies a function until it returns Nothing, and then returns the last answer.+--+-- >>> fmap rezip $ zipper ("hello","world") & downward _1 & within traverse <&> rightmost <&> focus .~ 'a'+-- ("hella","world")+--+-- >>> rezip $ zipper ("hello","there") & fromWithin (both.traverse) & rightmost & focus .~ 'm'+-- ("hello","therm") farthest :: (a -> Maybe a) -> a -> a farthest f = go where go a = maybe a go (f a) {-# INLINE farthest #-} --- | This allows for you to repeatedly pull a 'zipper' in a given direction, failing if it falls of the end.-jerks :: (a -> Maybe a) -> Int -> a -> Maybe a+-- | This allows for you to repeatedly pull a 'zipper' in a given direction, failing if it falls off the end.+--+-- >>> isNothing $ zipper "hello" & within traverse >>= jerks rightward 10+-- True+--+-- >>> fmap rezip $ zipper "silly" & within traverse >>= jerks rightward 3 <&> focus .~ 'k'+-- "silky"+jerks :: Monad m => (a -> m a) -> Int -> a -> m a jerks f n0- | n0 < 0 = error "jerks: negative jerk count"+ | n0 < 0 = fail "jerks: negative jerk count" | otherwise = go n0 where- go 0 a = Just a+ go 0 a = return a go n a = f a >>= go (n - 1) {-# INLINE jerks #-} @@ -150,69 +272,117 @@ -- @'teeth' z '>=' 1@ -- -- /NB:/ If the current 'Traversal' targets an infinite number of elements then this may not terminate.-teeth :: (a :> b) -> Int-teeth (Zipper _ w) = levelWidth w+--+-- >>> zipper ("hello","world") & teeth+-- 1+--+-- >>> zipper ("hello","world") & fromWithin both & teeth+-- 2+--+-- >>> zipper ("hello","world") & downward _1 & teeth+-- 1+--+-- >>> zipper ("hello","world") & downward _1 & fromWithin traverse & teeth+-- 5+--+-- >>> zipper ("hello","world") & fromWithin (_1.traverse) & teeth+-- 5+--+-- >>> zipper ("hello","world") & fromWithin (both.traverse) & teeth+-- 10+teeth :: (h :> a) -> Int+teeth (Zipper _ n _ _ rs) = n + 1 + length rs {-# INLINE teeth #-} --- | Move the 'zipper' horizontally to the element in the @n@th position in the current level, absolutely indexed, starting with the @'farthest' 'left'@ as @0@.+-- | Move the 'Zipper' horizontally to the element in the @n@th position in the+-- current level, absolutely indexed, starting with the 'farthest' 'leftward' as @0@. -- -- This returns 'Nothing' if the target element doesn't exist. ----- @'jerkTo' n ≡ 'jerks' 'right' n . 'farthest' 'left'@-jerkTo :: Int -> (a :> b) -> Maybe (a :> b)+-- @'jerkTo' n ≡ 'jerks' 'rightward' n . 'farthest' 'leftward'@+--+-- >>> isNothing $ zipper "not working." & jerkTo 20+-- True++-- >>> isNothing $ zipper "not working." & fromWithin traverse & jerkTo 20+-- True+--+-- >>> fmap rezip $ zipper "not working" & within traverse >>= jerkTo 2 <&> focus .~ 'w'+-- Just "now working"+jerkTo :: MonadPlus m => Int -> (h :> a) -> m (h :> a) jerkTo n z = case compare k n of- LT -> jerks left (n - k) z- EQ -> Just z- GT -> jerks right (k - n) z+ LT -> jerks rightward (n - k) z+ EQ -> return z+ GT -> jerks leftward (k - n) z where k = tooth z {-# INLINE jerkTo #-} --- | Move the 'zipper' horizontally to the element in the @n@th position of the current level, absolutely indexed, starting with the @'farthest' 'left'@ as @0@.+-- | Move the 'Zipper' horizontally to the element in the @n@th position of the+-- current level, absolutely indexed, starting with the 'farthest' 'leftward' as @0@. -- -- If the element at that position doesn't exist, then this will clamp to the range @0 <= n < 'teeth'@. ----- @'tugTo' n ≡ 'tugs' 'right' n . 'farthest' 'left'@-tugTo :: Int -> (a :> b) -> a :> b+-- @'tugTo' n ≡ 'tugs' 'rightward' n . 'farthest' 'leftward'@+--+-- >>> rezip $ zipper "not working." & fromWithin traverse & tugTo 100 & focus .~ '!' & tugTo 1 & focus .~ 'u'+-- "nut working!"+tugTo :: Int -> (h :> a) -> h :> a tugTo n z = case compare k n of- LT -> tugs left (n - k) z+ LT -> tugs rightward (n - k) z EQ -> z- GT -> tugs right (k - n) z+ GT -> tugs leftward (k - n) z where k = tooth z {-# INLINE tugTo #-} -- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know--- there is precisely one target.+-- there is precisely one target that can never fail. -- -- @--- 'down' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c--- 'down' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c+-- 'downward' :: 'Simple' 'Lens' s a -> (h :> s) -> h :> s :> a+-- 'downward' :: 'Simple' 'Iso' s a -> (h :> s) -> h :> s :> a -- @-down :: SimpleLensLike (Context c c) b c -> (a :> b) -> a :> b :> c-down l (Zipper h (Level n ls b rs)) = case l (Context id) b of- Context k c -> Zipper (Snoc h n (cloneLens l) ls (k . extract) rs) (Level 0 [] c [])-{-# INLINE down #-}+downward :: SimpleLensLike (Context a a) s a -> (h :> s) -> h :> s :> a+downward l (Zipper h n ls s rs) = case l (Context id) s of+ Context k a -> Zipper (Snoc h (cloneLens l) n ls (k . head) rs) 0 [] a []+{-# INLINE downward #-} -- | Step down into the 'leftmost' entry of a 'Traversal'. -- -- @--- 'within' :: 'Simple' 'Traversal' b c -> (a :> b) -> Maybe (a :> b :> c)--- 'within' :: 'Simple' 'Lens' b c -> (a :> b) -> Maybe (a :> b :> c)--- 'within' :: 'Simple' 'Iso' b c -> (a :> b) -> Maybe (a :> b :> c)+-- 'within' :: 'Simple' 'Traversal' s a -> (h :> s) -> Maybe (h :> s :> a)+-- 'within' :: 'Simple' 'Lens' s a -> (h :> s) -> Maybe (h :> s :> a)+-- 'within' :: 'Simple' 'Iso' s a -> (h :> s) -> Maybe (h :> s :> a) -- @-within :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> Maybe (a :> b :> c)-within l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of- Context _ [] -> Nothing- Context k (c:cs) -> Just (Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) (Level 0 [] c cs))+within :: MonadPlus m => SimpleLensLike (Bazaar a a) s a -> (h :> s) -> m (h :> s :> a)+within l (Zipper h n ls s rs) = case partsOf' l (Context id) s of+ Context _ [] -> mzero+ Context k (a:as) -> return (Zipper (Snoc h l n ls k rs) 0 [] a as) {-# INLINE within #-} +-- | Step down into every entry of a 'Traversal' simultaneously.+--+-- >>> zipper ("hello","world") & withins both >>= leftward >>= withins traverse >>= rightward <&> focus %~ toUpper <&> rezip+-- [("hEllo","world"),("heLlo","world"),("helLo","world"),("hellO","world")]+--+-- @+-- 'withins' :: 'Simple' 'Traversal' s a -> (h :> s) -> [h :> s :> a]+-- 'withins' :: 'Simple' 'Lens' s a -> (h :> s) -> [h :> s :> a]+-- 'withins' :: 'Simple' 'Iso' s a -> (h :> s) -> [h :> s :> a]+-- @+withins :: SimpleLensLike (Bazaar a a) s a -> (h :> s) -> [h :> s :> a]+withins l (Zipper h n ls s rs) = case partsOf' l (Context id) s of+ Context k ys -> go k [] ys+ where go k xs (y:ys) = Zipper (Snoc h l n ls k rs) 0 xs y ys : go k (y:xs) ys+ go _ _ [] = []+ -- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty. -- -- If this invariant is not met then this will usually result in an error! -- -- @--- 'fromWithin' :: 'Simple' 'Traversal' b c -> (a :> b) -> a :> b :> c--- 'fromWithin' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c--- 'fromWithin' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c+-- 'fromWithin' :: 'Simple' 'Traversal' s a -> (h :> s) -> h :> s :> a+-- 'fromWithin' :: 'Simple' 'Lens' s a -> (h :> s) -> h :> s :> a+-- 'fromWithin' :: 'Simple' 'Iso' s a -> (h :> s) -> h :> s :> a -- @ -- -- You can reason about this function as if the definition was:@@ -221,27 +391,32 @@ -- -- but it is lazier in such a way that if this invariant is violated, some code -- can still succeed if it is lazy enough in the use of the focused value.-fromWithin :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> a :> b :> c-fromWithin l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of- Context k cs -> Zipper (Snoc h n l ls (k . NonEmpty.toList) rs)- (Level 0 [] (Prelude.head cs) (Prelude.tail cs))+fromWithin :: SimpleLensLike (Bazaar a a) s a -> (h :> s) -> h :> s :> a+fromWithin l (Zipper h n ls s rs) = case partsOf' l (Context id) s of+ Context k ~(a:as) -> Zipper (Snoc h l n ls k rs) 0 [] a as {-# INLINE fromWithin #-} --- | This enables us to pull the 'zipper' back up to the 'Top'.-class Zipper h a where- recoil :: Coil h a -> NonEmpty a -> Zipped h a+-- | This enables us to pull the 'Zipper' back up to the 'Top'.+class Zipping h a where+ recoil :: Coil h a -> [a] -> Zipped h a -instance Zipper Top a where- recoil Coil = extract+instance Zipping Top a where+ recoil Coil = head+ {-# INLINE recoil #-} -instance Zipper h b => Zipper (h :> b) c where- recoil (Snoc h _ _ ls k rs) as = recoil h (NonEmpty.fromList (Prelude.reverse ls ++ k as : rs))+instance Zipping h s => Zipping (h :> s) a where+ recoil (Snoc h _ _ ls k rs) as = recoil h (reverseList ls ++ k as : rs)+ {-# INLINE recoil #-} --- | Close something back up that you opened as a 'zipper'.-rezip :: Zipper h a => (h :> a) -> Zipped h a-rezip (Zipper h w) = recoil h (rezipLevel w)+-- | Close something back up that you opened as a 'Zipper'.+rezip :: Zipping h a => (h :> a) -> Zipped h a+rezip (Zipper h _ ls a rs) = recoil h (reverseList ls ++ a : rs) {-# INLINE rezip #-} +-- | Extract the current 'focus' from a 'Zipper' as a 'Context'+focusedContext :: Zipping h a => (h :> a) -> Context a a (Zipped h a)+focusedContext z = Context (\a -> z & focus .~ a & rezip) (z^.focus)+ ----------------------------------------------------------------------------- -- * Tapes -----------------------------------------------------------------------------@@ -251,34 +426,34 @@ Tape :: Track h a -> {-# UNPACK #-} !Int -> Tape (h :> a) -- | Save the current path as as a 'Tape' we can play back later.-saveTape :: (a :> b) -> Tape (a :> b)-saveTape (Zipper h (Level n _ _ _)) = Tape (peel h) n+saveTape :: (h :> a) -> Tape (h :> a)+saveTape (Zipper h n _ _ _) = Tape (peel h) n {-# INLINE saveTape #-} -- | Restore ourselves to a previously recorded position precisely. -- -- If the position does not exist, then fail.-restoreTape :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a)-restoreTape (Tape h n) = restoreTrack h >=> jerks right n+restoreTape :: MonadPlus m => Tape (h :> a) -> Zipped h a -> m (h :> a)+restoreTape (Tape h n) = restoreTrack h >=> jerks rightward n {-# INLINE restoreTape #-} -- | Restore ourselves to a location near our previously recorded position. -- -- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, -- so the only failures will occur when one of the sequence of downward traversals find no targets.-restoreNearTape :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a)-restoreNearTape (Tape h n) a = tugs right n <$> restoreNearTrack h a+restoreNearTape :: MonadPlus m => Tape (h :> a) -> Zipped h a -> m (h :> a)+restoreNearTape (Tape h n) a = liftM (tugs rightward n) (restoreNearTrack h a) {-# INLINE restoreNearTape #-} -- | Restore ourselves to a previously recorded position. -- -- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path. ----- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty.+-- Motions leftward or rightward are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. -- -- Violate these assumptions at your own risk! unsafelyRestoreTape :: Tape (h :> a) -> Zipped h a -> h :> a-unsafelyRestoreTape (Tape h n) = unsafelyRestoreTrack h >>> tugs right n+unsafelyRestoreTape (Tape h n) = unsafelyRestoreTrack h >>> tugs rightward n {-# INLINE unsafelyRestoreTape #-} -----------------------------------------------------------------------------@@ -288,127 +463,54 @@ -- | This is used to peel off the path information from a 'Coil' for use when saving the current path for later replay. peel :: Coil h a -> Track h a peel Coil = Track-peel (Snoc h n l _ _ _) = Fork (peel h) n l+peel (Snoc h l n _ _ _) = Fork (peel h) n l -- | The 'Track' forms the bulk of a 'Tape'. data Track :: * -> * -> * where Track :: Track Top a- Fork :: Track h b -> {-# UNPACK #-} !Int -> SimpleLensLike (Bazaar a a) b a -> Track (h :> b) a+ Fork :: Track h s -> {-# UNPACK #-} !Int -> SimpleLensLike (Bazaar a a) s a -> Track (h :> s) a -- | Restore ourselves to a previously recorded position precisely. -- -- If the position does not exist, then fail.-restoreTrack :: Track h a -> Zipped h a -> Maybe (h :> a)-restoreTrack Track = Just . zipper-restoreTrack (Fork h n l) = restoreTrack h >=> jerks right n >=> within l+restoreTrack :: MonadPlus m => Track h a -> Zipped h a -> m (h :> a)+restoreTrack Track = return . zipper+restoreTrack (Fork h n l) = restoreTrack h >=> jerks rightward n >=> within l -- | Restore ourselves to a location near our previously recorded position. ----- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@,+-- When moving leftward to rightward through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, -- so the only failures will occur when one of the sequence of downward traversals find no targets.-restoreNearTrack :: Track h a -> Zipped h a -> Maybe (h :> a)-restoreNearTrack Track = Just . zipper-restoreNearTrack (Fork h n l) = restoreNearTrack h >=> tugs right n >>> within l+restoreNearTrack :: MonadPlus m => Track h a -> Zipped h a -> m (h :> a)+restoreNearTrack Track = return . zipper+restoreNearTrack (Fork h n l) = restoreNearTrack h >=> tugs rightward n >>> within l -- | Restore ourselves to a previously recorded position. -- -- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path. ----- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty.+-- Motions leftward or rightward are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. -- -- Violate these assumptions at your own risk! unsafelyRestoreTrack :: Track h a -> Zipped h a -> h :> a unsafelyRestoreTrack Track = zipper-unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> tugs right n >>> fromWithin l+unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> tugs rightward n >>> fromWithin l -------------------------------------------------------------------------------- * Levels+-- * Helper functions ----------------------------------------------------------------------------- --- | A basic non-empty list zipper------ All combinators assume the invariant that the length stored matches the number--- of elements in list of items to the left, and the list of items to the left is--- stored reversed.-data Level a = Level {-# UNPACK #-} !Int [a] a [a]---- | How many entries are there in this level?-levelWidth :: Level a -> Int-levelWidth (Level n _ _ rs) = n + 1 + length rs-{-# INLINE levelWidth #-}---- | Pull the non-empty list zipper left one entry-leftLevel :: Level a -> Maybe (Level a)-leftLevel (Level _ [] _ _ ) = Nothing-leftLevel (Level n (l:ls) a rs) = Just (Level (n - 1) ls l (a:rs))-{-# INLINE leftLevel #-}---- | Pull the non-empty list zipper left one entry, stopping at the first entry.-left1Level :: Level a -> Level a-left1Level z = fromMaybe z (leftLevel z)-{-# INLINE left1Level #-}---- | Pull the non-empty list zipper all the way to the left.-leftmostLevel :: Level a -> Level a-leftmostLevel (Level _ ls m rs) = case Prelude.reverse ls ++ m : rs of- (c:cs) -> Level 0 [] c cs- _ -> error "the impossible happened"-{-# INLINE leftmostLevel #-}---- | Pul the non-empty list zipper all the way to the right.--- /NB:/, when given an infinite list this may not terminate.-rightmostLevel :: Level a -> Level a-rightmostLevel (Level _ ls m rs) = go 0 [] (Prelude.head xs) (Prelude.tail xs) where- xs = Prelude.reverse ls ++ m : rs- go n zs y [] = Level n zs y []- go n zs y (w:ws) = (go $! n + 1) (y:zs) w ws-{-# INLINE rightmostLevel #-}---- | Pull the non-empty list zipper right one entry.-rightLevel :: Level a -> Maybe (Level a)-rightLevel (Level _ _ _ [] ) = Nothing-rightLevel (Level n ls a (r:rs)) = Just (Level (n + 1) (a:ls) r rs)-{-# INLINE rightLevel #-}---- | Pull the non-empty list zipper right one entry, stopping at the last entry.-right1Level :: Level a -> Level a-right1Level z = fromMaybe z (rightLevel z)-{-# INLINE right1Level #-}---- | This is a 'Lens' targeting the value that we would 'extract' from the non-empty list zipper.+-- | Reverse a list. ----- @'view' 'focusLevel' ≡ 'extract'@+-- GHC doesn't optimize @reverse []@ into @[]@, so we'll nudge it with our own+-- reverse function. ----- @'focusLevel' :: 'Simple' 'Lens' ('Level' a) a@-focusLevel :: Functor f => (a -> f a) -> Level a -> f (Level a)-focusLevel f (Level n ls a rs) = (\b -> Level n ls b rs) <$> f a-{-# INLINE focusLevel #-}--instance Functor Level where- fmap f (Level n ls a rs) = Level n (f <$> ls) (f a) (f <$> rs)--instance Foldable Level where- foldMap f (Level _ ls a rs) = foldMapOf (backwards folded) f ls <> f a <> foldMap f rs--instance Traversable Level where- traverse f (Level n ls a rs) = Level n <$> forwards (traverse (Backwards . f) ls) <*> f a <*> traverse f rs---- | Zip a non-empty list zipper back up, and return the result.-rezipLevel :: Level a -> NonEmpty a-rezipLevel (Level _ ls a rs) = NonEmpty.fromList (Prelude.reverse ls ++ a : rs)-{-# INLINE rezipLevel #-}--instance Comonad Level where- extract (Level _ _ a _) = a- extend f w@(Level n ls m rs) = Level n (gol (n - 1) (m:rs) ls) (f w) (gor (n + 1) (m:ls) rs) where- gol k zs (y:ys) = f (Level k ys y zs) : (gol $! k - 1) (y:zs) ys- gol _ _ [] = []- gor k ys (z:zs) = f (Level k ys z zs) : (gor $! k + 1) (z:ys) zs- gor _ _ [] = []--instance ComonadStore Int Level where- pos (Level n _ _ _) = n- peek n (Level m ls a rs) = case compare n m of- LT -> ls Prelude.!! (m - n)- EQ -> a- GT -> rs Prelude.!! (n - m)+-- This is relevant when descending into a lens, for example -- we know the+-- unzipped part of the level will be empty.+reverseList :: [a] -> [a]+reverseList [] = []+reverseList (x:xs) = go [x] xs+ where+ go a [] = a+ go a (y:ys) = go (y:a) ys+{-# INLINE reverseList #-}
src/Control/Lens/Iso.hs view
@@ -1,5 +1,17 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif++#ifndef MIN_VERSION_bytestring+#define MIN_VERSION_bytestring(x,y,z)+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Iso@@ -14,158 +26,127 @@ ( -- * Isomorphism Lenses Iso- , iso- , isos+ , AnIso+ -- * Isomorphism Construction+ , Isomorphic(..)+ , Isoid(..)+ -- * Consuming Isomorphisms+ , from+ , cloneIso -- * Working with isomorphisms- , ala+ , au , auf , under , mapping- , review- -- * Primitive isomorphisms- , from- , via- , Isomorphism(..)- , Isomorphic(..) -- ** Common Isomorphisms- , _const- , identity , simple , non+ , anon , enum- -- * Storing Isomorphisms- , ReifiedIso(..)+ , curried, uncurried+ , Strict(..) -- * Simplicity , SimpleIso- , SimpleReifiedIso+ -- * Useful Type Families+ , CoA, CoB ) where -import Control.Applicative import Control.Category-import Control.Lens.Getter+import Control.Lens.Classes import Control.Lens.Internal-import Control.Lens.Isomorphic-import Control.Lens.Setter import Control.Lens.Type-import Data.Functor.Identity-import Data.Maybe (fromMaybe)+import Data.ByteString as StrictB+import Data.ByteString.Lazy as LazyB+import Data.Text as StrictT+import Data.Text.Lazy as LazyT+import Data.Maybe import Prelude hiding ((.),id) -- $setup -- >>> import Control.Lens -- >>> import Data.Map as Map+-- >>> import Data.Foldable+-- >>> import Data.Monoid --------------------------------------------------------------------------------- Isomorphisms families as Lenses+----------------------------------------------------------------------------+-- Consuming Isomorphisms ----------------------------------------------------------------------------- --- | Isomorphism families can be composed with other lenses using either ('.') and 'id'--- from the Prelude or from Control.Category. However, if you compose them--- with each other using ('.') from the Prelude, they will be dumbed down to a--- mere 'Lens'.+-- | Invert an isomorphism. ----- @--- import Control.Category--- import Prelude hiding (('Prelude..'),'Prelude.id')--- @+-- @'from' ('from' l) ≡ l@+from :: AnIso s t a b -> Iso b a t s+from Isoid = id+from (Iso sa bt) = iso bt sa+{-# INLINE from #-}++-- | Convert from an 'Isomorphism' back to any 'Isomorphic' value. ----- @type 'Iso' s t a b = forall k f. ('Isomorphic' k, 'Functor' f) => 'Overloaded' k f s t a b@+-- This is useful when you need to store an isomorphism as a data type inside a container+-- and later reconstitute it as an overloaded function.+--+-- See 'cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this.+cloneIso :: AnIso s t a b -> Iso s t a b+cloneIso Isoid = id+cloneIso (Iso sa bt) = iso sa bt+{-# INLINE cloneIso #-}++-----------------------------------------------------------------------------+-- Isomorphisms families as Lenses+-----------------------------------------------------------------------------++-- | Isomorphism families can be composed with other lenses using ('.') and 'id'. type Iso s t a b = forall k f. (Isomorphic k, Functor f) => k (a -> f b) (s -> f t) +-- | When you see this as an argument to a function, it expects an 'Iso'.+type AnIso s t a b = Overloaded Isoid Mutator s t a b+ -- | -- @type 'SimpleIso' = 'Control.Lens.Type.Simple' 'Iso'@ type SimpleIso s a = Iso s s a a ---- | Build an isomorphism family from two pairs of inverse functions------ @--- 'view' ('isos' sa as tb bt) ≡ sa--- 'view' ('from' ('isos' sa as tb bt)) ≡ as--- 'set' ('isos' sa as tb bt) ab ≡ bt '.' ab '.' sa--- 'set' ('from' ('isos' ac ca bd db)) ab ≡ bd '.' ab '.' ca--- @------ @isos :: (s -> a) -> (a -> s) -> (t -> b) -> (b -> t) -> 'Iso' s t a b@-isos :: (Isomorphic k, Functor f) => (s -> a) -> (a -> s) -> (t -> b) -> (b -> t) -> k (a -> f b) (s -> f t)-isos sa as tb bt = isomorphic- (\afb s -> bt <$> afb (sa s))- (\sft a -> tb <$> sft (as a))-{-# INLINE isos #-}---- | Build a simple isomorphism from a pair of inverse functions--------- @--- 'view' ('iso' f g) ≡ f--- 'view' ('from' ('iso' f g)) ≡ g--- 'set' ('iso' f g) h ≡ g '.' h '.' f--- 'set' ('from' ('iso' f g)) h ≡ f '.' h '.' g--- @+-- | Based on 'Control.Lens.Wrapped.ala' from Conor McBride's work on Epigram. ----- @iso :: (s -> a) -> (a -> s) -> 'Control.Lens.Type.Simple' 'Iso' s a@-iso :: (Isomorphic k, Functor f) => (s -> a) -> (a -> s) -> k (a -> f a) (s -> f s)-iso sa as = isos sa as sa as-{-# INLINE iso #-}---- | Based on @ala@ from Conor McBride's work on Epigram.+-- This version is generalized to accept any 'Iso', not just a @newtype@. ----- >>> :m + Data.Monoid.Lens Data.Foldable--- >>> ala _sum foldMap [1,2,3,4]+-- >>> au (wrapping Sum) foldMap [1,2,3,4] -- 10-ala :: Simple Iso s a -> ((s -> a) -> e -> a) -> e -> s-ala l f e = f (view l) e ^. from l-{-# INLINE ala #-}+au :: AnIso s t a b -> ((s -> a) -> e -> b) -> e -> t+au Isoid f e = f id e+au (Iso sa bt) f e = bt (f sa e)+{-# INLINE au #-} -- | -- Based on @ala'@ from Conor McBride's work on Epigram. --+-- This version is generalized to accept any 'Iso', not just a @newtype@.+--+-- For a version you pass the name of the @newtype@ constructor to, see 'Control.Lens.Wrapped.alaf'.+-- -- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator--- is 'ala' with an extra function argument.-auf :: Simple Iso s a -> ((b -> a) -> e -> a) -> (b -> s) -> e -> s-auf l f g e = f (view l . g) e ^. from l+-- is 'au' with an extra function argument.+--+-- >>> auf (wrapping Sum) (foldMapOf both) Prelude.length ("hello","world")+-- 10+auf :: AnIso s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t+auf Isoid f g e = f g e+auf (Iso sa bt) f g e = bt (f (sa . g) e) {-# INLINE auf #-} -- | The opposite of working 'over' a Setter is working 'under' an Isomorphism. ----- @'under' = 'over' '.' 'from'@+-- @'under' ≡ 'over' '.' 'from'@ -- -- @'under' :: 'Iso' s t a b -> (s -> t) -> a -> b@-under :: Isomorphism (a -> Mutator b) (s -> Mutator t) -> (s -> t) -> a -> b-under = over . from+under :: AnIso s t a b -> (t -> s) -> b -> a+under Isoid ts b = ts b+under (Iso sa bt) ts b = sa (ts (bt b)) {-# INLINE under #-} --- | This can be used to turn an 'Iso' around and 'view' the other way.------ @'review' = 'view' '.' 'from'@-review :: Overloaded Isomorphism (Accessor s) s t a b -> a -> s-review (Isomorphism _ l) = view l-{-# INLINE review #-}- ----------------------------------------------------------------------------- -- Isomorphisms ----------------------------------------------------------------------------- --- | This isomorphism can be used to wrap or unwrap a value in 'Identity'.------ @--- x^.identity ≡ 'Identity' x--- 'Identity' x '^.' 'from' 'identity' ≡ x--- @-identity :: Iso a b (Identity a) (Identity b)-identity = isos Identity runIdentity Identity runIdentity-{-# INLINE identity #-}---- | This isomorphism can be used to wrap or unwrap a value in 'Const'------ @--- x '^.' '_const' ≡ 'Const' x--- 'Const' x '^.' 'from' '_const' ≡ x--- @-_const :: Iso a b (Const a c) (Const b d)-_const = isos Const getConst Const getConst-{-# INLINE _const #-}- -- | This isomorphism can be used to convert to or from an instance of 'Enum'. -- -- >>> LT^.from enum@@ -184,8 +165,9 @@ {-# INLINE enum #-} -- | This can be used to lift any 'SimpleIso' into an arbitrary functor.-mapping :: Functor f => SimpleIso s a -> SimpleIso (f s) (f a)-mapping l = iso (view l <$>) (view (from l) <$>)+mapping :: Functor f => AnIso s t a b -> Iso (f s) (f t) (f a) (f b)+mapping Isoid = id+mapping (Iso sa bt) = iso (fmap sa) (fmap bt) {-# INLINE mapping #-} -- | Composition with this isomorphism is occasionally useful when your 'Lens',@@ -193,7 +175,7 @@ -- argument to force that argument to agree with the -- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness. simple :: Simple Iso a a-simple = isomorphic id id+simple = id {-# INLINE simple #-} -- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@, then @non v@ is an isomorphism from@@ -222,23 +204,65 @@ -- >>> Map.empty & at "hello" . non Map.empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] ----- and when have deleting the last entry from the nested map mean that we +-- and when have deleting the last entry from the nested map mean that we -- should delete its entry from the surrounding one: -- -- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing -- fromList []- non :: Eq a => a -> Simple Iso (Maybe a) a-non a = iso (fromMaybe a) go where- go b | a == b = Nothing+non a = anon a (a==)+{-# INLINE non #-}++-- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate.+--+-- This function assumes that @p a@ holds @True@ and generates an isomorphism between @'Maybe' (a | not (p a))@ and @a@+--+-- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!"+-- fromList [("hello",fromList [("world","!!!")])]+--+-- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing+-- fromList []+anon :: a -> (a -> Bool) -> Simple Iso (Maybe a) a+anon a p = iso (fromMaybe a) go where+ go b | p b = Nothing | otherwise = Just b+{-# INLINE anon #-} --------------------------------------------------------------------------------- Reifying Isomorphisms------------------------------------------------------------------------------+-- | The canonical isomorphism for currying and uncurrying a function.+--+-- >>> :t fst^.curried+-- fst^.curried :: a -> b -> a+--+-- @'curried' = 'iso' 'curry' 'uncurry'@+curried :: Iso ((a,b) -> c) ((d,e) -> f) (a -> b -> c) (d -> e -> f)+curried = iso curry uncurry+{-# INLINE curried #-} --- | Useful for storing isomorphisms in containers.-newtype ReifiedIso s t a b = ReifyIso { reflectIso :: Iso s t a b }+-- | The canonical isomorphism for uncurrying and currying a function.+--+-- >>> :t flip (,)^.uncurried+-- flip (,)^.uncurried :: (b, a) -> (a, b)+--+-- @'uncurried' = 'iso' 'uncurry' 'curry'@+--+-- @'uncurried' = 'from' 'curried'@+uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a,b) -> c) ((d,e) -> f)+uncurried = iso uncurry curry+{-# INLINE uncurried #-} --- | @type 'SimpleReifiedIso' = 'Control.Lens.Type.Simple' 'ReifiedIso'@-type SimpleReifiedIso s a = ReifiedIso s s a a+-- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure,+-- such as 'StrictT.Text' or 'StrictB.ByteString'.+class Strict s t a b | s -> a, a -> s, b -> t, t -> b, s b -> a t, a t -> s b where+ strict :: Iso s t a b++instance Strict LazyB.ByteString LazyB.ByteString StrictB.ByteString StrictB.ByteString where+#if MIN_VERSION_bytestring(0,10,0)+ strict = iso LazyB.toStrict LazyB.fromStrict+#else+ strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return)+#endif+ {-# INLINE strict #-}++instance Strict LazyT.Text LazyT.Text StrictT.Text StrictT.Text where+ strict = iso LazyT.toStrict LazyT.fromStrict+ {-# INLINE strict #-}
− src/Control/Lens/Isomorphic.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : Control.Lens.Isomorphic--- Copyright : (C) 2012 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : Rank2Types---------------------------------------------------------------------------------module Control.Lens.Isomorphic- ( Isomorphic(..)- , Isomorphism(..)- , from- , via- ) where--import Control.Category-import Data.Typeable-import Prelude hiding ((.),id)--------------------------------------------------------------------------------- Isomorphism Implementation Details---------------------------------------------------------------------------------- | Used to provide overloading of isomorphism application------ This is a 'Category' with a canonical mapping to it from the--- category of isomorphisms over Haskell types.-class Category k => Isomorphic k where- -- | Build this morphism out of an isomorphism- --- -- The intention is that by using 'isomorphic', you can supply both halves of an- -- isomorphism, but k can be instantiated to @(->)@, so you can freely use- -- the resulting isomorphism as a function.- isomorphic :: (a -> b) -> (b -> a) -> k a b-- -- | Map a morphism in the target category using an isomorphism between morphisms- -- in Hask.- isomap :: ((a -> b) -> c -> d) -> ((b -> a) -> d -> c) -> k a b -> k c d--instance Isomorphic (->) where- isomorphic = const- {-# INLINE isomorphic #-}- isomap = const- {-# INLINE isomap #-}---- | A concrete data type for isomorphisms.------ This lets you place an isomorphism inside a container without using @ImpredicativeTypes@.-data Isomorphism a b = Isomorphism (a -> b) (b -> a)- deriving Typeable--instance Category Isomorphism where- id = Isomorphism id id- {-# INLINE id #-}- Isomorphism bc cb . Isomorphism ab ba = Isomorphism (bc . ab) (ba . cb)- {-# INLINE (.) #-}--instance Isomorphic Isomorphism where- isomorphic = Isomorphism- {-# INLINE isomorphic #-}- isomap abcd badc (Isomorphism ab ba) = Isomorphism (abcd ab) (badc ba)- {-# INLINE isomap #-}---- | Invert an isomorphism.------ Note to compose an isomorphism and receive an isomorphism in turn you'll need to use--- 'Control.Category.Category'------ @'from' ('from' l) ≡ l@------ If you imported 'Control.Category..' from @Control.Category@, then:------ @'from' l '.' 'from' r ≡ 'from' (r '.' l)@-from :: Isomorphic k => Isomorphism a b -> k b a-from (Isomorphism a b) = isomorphic b a-{-# INLINE from #-}---- | Convert from an 'Isomorphism' back to any 'Isomorphic' value.------ This is useful when you need to store an isomoprhism as a data type inside a container--- and later reconstitute it as an overloaded function.-via :: Isomorphic k => Isomorphism a b -> k a b-via (Isomorphism a b) = isomorphic a b-{-# INLINE via #-}
src/Control/Lens/Loupe.hs view
@@ -49,7 +49,7 @@ -- A @'Loupe' s t a b@ is almost a 'Lens'. It can be composed on the left of other lenses, -- you can use 'cloneLens' to promote it to a 'Lens', and it provides a minimalist lens-like -- interface. They can be used in an API where you need to pass around lenses inside containers--- or as monadic results. Unlike a 'ReifiedLens' they can be composed and used directly, but +-- or as monadic results. Unlike a 'ReifiedLens' they can be composed and used directly, but -- they are slightly lower performance. -- 1) You get back what you put in:@@ -74,30 +74,45 @@ type SimpleLoupe s a = Loupe s s a a -- | A 'Loupe'-specific version of ('Control.Lens.Getter.^.')+--+-- >>> ("hello","world")^#_2+-- "world" (^#) :: s -> Loupe s t a b -> a s ^# l = case l (Context id) s of Context _ a -> a {-# INLINE (^#) #-} -- | A 'Loupe'-specific version of 'Control.Lens.Setter.set'+--+-- >>> storing _2 "world" ("hello","there")+-- ("hello","world") storing :: Loupe s t a b -> b -> s -> t storing l b s = case l (Context id) s of Context g _ -> g b {-# INLINE storing #-} -- | A 'Loupe'-specific version of ('Control.Lens.Setter..~')+--+-- >>> ("hello","there") & _2 #~ "world"+-- ("hello","world") (#~) :: Loupe s t a b -> b -> s -> t (#~) l b s = case l (Context id ) s of Context g _ -> g b {-# INLINE (#~) #-} -- | A 'Loupe'-specific version of ('Control.Lens.Setter.%~')+--+-- >>> ("hello","world") & _2 #%~ length+-- ("hello",5) (#%~) :: Loupe s t a b -> (a -> b) -> s -> t (#%~) l f s = case l (Context id) s of Context g a -> g (f a) {-# INLINE (#%~) #-} -- | A 'Loupe'-specific version of ('Control.Lens.Type.%%~')+--+-- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!")+-- (5,("hello","world!")) (#%%~) :: Functor f => Loupe s t a b -> (a -> f b) -> s -> f t (#%%~) l f s = case l (Context id) s of Context g a -> g <$> f a@@ -113,6 +128,9 @@ {-# INLINE (#%=) #-} -- | Modify the target of a 'Loupe' and return the result.+--+-- >>> ("hello","world") & _2 <#%~ length+-- (5,("hello",5)) (<#%~) :: Loupe s t a b -> (a -> b) -> s -> (b, t) l <#%~ f = \s -> case l (Context id) s of Context g a -> let b = f a in (b, g b)@@ -123,7 +141,7 @@ l <#%= f = l #%%= \a -> let b = f a in (b,b) {-# INLINE (<#%=) #-} --- | Modify the target of a 'Loupe' in the current monadic state, returning an auxillary result.+-- | Modify the target of a 'Loupe' in the current monadic state, returning an auxiliary result. (#%%=) :: MonadState s m => Loupe s s a b -> (a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,1) l #%%= f = State.state $ \s -> case l (Context id) s of@@ -137,6 +155,9 @@ #endif -- | Replace the target of a 'Loupe' and return the new value.+--+-- >>> ("hello","there") & _2 <#~ "world"+-- ("world",("hello","world")) (<#~) :: Loupe s t a b -> b -> s -> (b, t) l <#~ b = \s -> (b, storing l b s)
src/Control/Lens/Plated.hs view
@@ -1,10 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+#ifdef DEFAULT_SIGNATURES+{-# LANGUAGE DefaultSignatures #-}+#endif+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-} -- template-haskell+#endif+ #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif@@ -29,7 +35,7 @@ -- -- By implementing these combinators in terms of 'plate' instead of 'uniplate' -- additional type safety is gained, as the user is no longer responsible for--- maintaining invariants such as the number of children he received.+-- maintaining invariants such as the number of children they received. -- -- Note: The @Biplate@ is /deliberately/ excluded from the API here, with the -- intention that you replace them with either explicit traversals, or by using the@@ -81,7 +87,9 @@ import Control.Lens.Traversal import Control.Lens.Type import qualified Language.Haskell.TH as TH+#ifdef DEFAULT_SIGNATURES import Data.Data+#endif import Data.Data.Lens import Data.Monoid import Data.Tree@@ -175,10 +183,14 @@ class Plated a where -- | 'Traversal' of the immediate children of this structure. --- -- The default definition finds no children.+ -- If you're using GHC 7.2 or newer and your type has a 'Data' instance,+ -- 'plate' will default to 'uniplate' and you can choose to not override+ -- it with your own definition. plate :: Simple Traversal a a+#ifdef DEFAULT_SIGNATURES default plate :: Data a => Simple Traversal a a plate = uniplate+#endif instance Plated [a] where plate f (x:xs) = (x:) <$> f xs@@ -187,15 +199,15 @@ instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as -instance Plated TH.Exp-instance Plated TH.Dec-instance Plated TH.Con-instance Plated TH.Type+instance Plated TH.Exp where plate = uniplate+instance Plated TH.Dec where plate = uniplate+instance Plated TH.Con where plate = uniplate+instance Plated TH.Type where plate = uniplate #if !(MIN_VERSION_template_haskell(2,8,0))-instance Plated TH.Kind -- in 2.8 Kind is an alias for Type+instance Plated TH.Kind where plate = uniplate -- in 2.8 Kind is an alias for Type #endif-instance Plated TH.Stmt-instance Plated TH.Pat+instance Plated TH.Stmt where plate = uniplate+instance Plated TH.Pat where plate = uniplate ------------------------------------------------------------------------------- -- Children
+ src/Control/Lens/Prism.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif+-------------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Prism+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+-------------------------------------------------------------------------------+module Control.Lens.Prism+ (+ -- * Prisms+ Prism+ , APrism+ -- * Constructing Prisms+ , Prismatic(..)+ , Prismoid(..)++ -- * Consuming Prisms+ , clonePrism+ , remit+ , review, reviews+ , reuse, reuses+ , outside+ , aside+ , without++ -- * Common Prisms+ , _left+ , _right+ , _just++ -- * Simple+ , SimplePrism+ ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad.Reader as Reader+import Control.Monad.State as State+import Control.Lens.Classes+import Control.Lens.Combinators+import Control.Lens.Getter+import Control.Lens.Internal+import Control.Lens.Type+import Prelude hiding (id,(.))++-- $setup+-- >>> import Control.Lens+-- >>> import Numeric.Natural+-- >>> :set -XFlexibleContexts -XTypeFamilies+-- >>> let nat :: Simple Prism Integer Natural; nat = prism toInteger $ \i -> if i <= 0 then Left i else Right (fromInteger i)+-- >>> let isLeft (Left _) = True; isLeft _ = False+-- >>> let isRight (Right _) = True; isRight _ = False++------------------------------------------------------------------------------+-- Prism Internals+------------------------------------------------------------------------------++-- | A 'Prism' @l@ is a 0-or-1 target 'Traversal' that can also be turned around with 'remit' to+-- obtain a 'Getter' in the opposite direction, such that in addition to the 'Traversal' laws, we also+-- have+--+-- @x '^.' 'remit' l '^?' l ≡ 'Just' x@+--+-- @'Control.Lens.Fold.lengthOf' l x '<=' 1@+--+-- It may help to think of this as a 'Control.Lens.Iso.Iso' that can be partial in one direction.+--+-- Every 'Prism' is a valid 'Traversal'.+--+-- Every 'Control.Lens.Iso.Iso' is a valid 'Prism'.+--+-- For example, you might have a @'Simple' 'Prism' 'Integer' Natural@ allows you to always+-- go from a 'Natural' to an 'Integer', and provide you with tools to check if an 'Integer' is+-- a 'Natural' and/or to edit one if it is.+--+--+-- @+-- 'nat' :: 'Simple' 'Prism' 'Integer' 'Numeric.Natural.Natural'+-- 'nat' = 'prism' 'toInteger' '$' \\ i ->+-- if i '<' 0+-- then 'Left' i+-- else 'Right' ('fromInteger' i)+-- @+--+-- Now we can ask if an 'Integer' is a 'Natural'.+--+-- >>> 5^?nat+-- Just 5+--+-- >>> (-5)^?nat+-- Nothing+--+-- We can update the ones that are:+--+-- >>> (-3,4) & both.nat *~ 2+-- (-3,8)+--+-- And we can then convert from a 'Natural' to an 'Integer'.+--+-- >>> 5 ^. remit nat -- :: Natural+-- 5+--+-- Similarly we can use a 'Prism' to 'traverse' the left half of an 'Either':+--+-- >>> Left "hello" & _left %~ length+-- Left 5+--+-- or to construct an 'Either':+--+-- >>> 5^.remit _left+-- Left 5+--+-- such that if you query it with the 'Prism', you will get your original input back.+--+-- >>> 5^.remit _left ^? _left+-- Just 5+--+-- Another interesting way to think of a 'Prism' is as the categorical dual of a 'Lens'+-- a /co/-'Lens', so to speak. This is what permits the construction of 'outside'.+type Prism s t a b = forall k f. (Prismatic k, Applicative f) => k (a -> f b) (s -> f t)++-- | If you see this in a signature for a function, the function is expecting a 'Prism',+-- not some kind of alien invader.+type APrism s t a b = Overloaded Prismoid Mutator s t a b++-- | A @'Simple' 'Prism'@.+type SimplePrism s a = Prism s s a a++-- | Clone a 'Prism' so that you can reuse the same monomorphically typed 'Prism' for different purposes.+--+-- See 'cloneLens' and 'cloneTraversal' for examples of why you might want to do this.+clonePrism :: APrism s t a b -> Prism s t a b+clonePrism Prismoid = id+clonePrism (Prism f g) = prism f g++------------------------------------------------------------------------------+-- Prism Combinators+------------------------------------------------------------------------------++-- | Use a 'Prism' as a kind of first-class pattern.+--+-- @'outside' :: 'Prism' s t a b -> 'Lens' (t -> r) (s -> r) (b -> r) (a -> r)@+outside :: APrism s t a b -> Lens (t -> r) (s -> r) (b -> r) (a -> r)+outside Prismoid f tr = f tr+outside (Prism bt seta) f tr = f (tr.bt) <&> \ar -> either tr ar . seta++-- | Use a 'Prism' to work over part of a structure.+aside :: APrism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)+aside Prismoid = id+aside (Prism bt seta) = prism (fmap bt) $ \(e,s) -> case seta s of+ Left t -> Left (e,t)+ Right a -> Right (e,a)++-- | Given a pair of prisms, project sums.+--+-- Viewing a 'Prism' as a co-lens, this combinator can be seen to be dual to 'alongside'.+without :: APrism s t a b+ -> APrism u v c d+ -> Prism (Either s u) (Either t v) (Either a c) (Either b d)+without Prismoid Prismoid = id+without (Prism bt seta) Prismoid = prism (left bt) go where+ go (Left s) = either (Left . Left) (Right . Left) (seta s)+ go (Right u) = Right (Right u)+without Prismoid (Prism dv uevc) = prism (right dv) go where+ go (Left s) = Right (Left s)+ go (Right u) = either (Left . Right) (Right . Right) (uevc u)+without (Prism bt seta) (Prism dv uevc) = prism (bt +++ dv) go where+ go (Left s) = either (Left . Left) (Right . Left) (seta s)+ go (Right u) = either (Left . Right) (Right . Right) (uevc u)++-- | Turn a 'Prism' or 'Control.Lens.Iso.Iso' around to build a 'Getter'.+--+-- If you have an 'Control.Lens.Iso.Iso', 'Control.Lens.Iso.from' is a more powerful version of this function+-- that will return an 'Control.Lens.Iso.Iso' instead of a mere 'Getter'.+--+-- >>> 5 ^.remit _left+-- Left 5+--+-- @+-- 'remit' :: 'Prism' s t a b -> 'Getter' b t+-- 'remit' :: 'Iso' s t a b -> 'Getter' b t+-- @+remit :: APrism s t a b -> Getter b t+remit Prismoid = id+remit (Prism bt _) = to bt++-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way.+--+-- @'review' ≡ 'view' '.' 'remit'@+--+-- >>> review _left "mustard"+-- Left "mustard"+--+-- Usually 'review' is used in the @(->)@ monad with a 'Simple' 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of+-- it as having one of these more restricted type signatures:+--+-- @+-- 'review' :: 'Simple' 'Iso' s a -> a -> s+-- 'review' :: 'Simple' 'Prism' s a -> a -> s+-- @+--+-- However, when working with a monad transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of+-- these more slightly more liberal type signatures may be beneficial to think of it as having:+--+-- @+-- 'review' :: 'MonadReader' a m => 'Simple' 'Iso' s a -> m s+-- 'review' :: 'MonadReader' a m => 'Simple' 'Prism' s a -> m s+-- @+review :: MonadReader b m => APrism s t a b -> m t+review Prismoid = ask+review (Prism bt _) = asks bt+{-# INLINE review #-}++-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way,+-- applying a function.+--+-- @'reviews' ≡ 'views' '.' 'remit'@+--+-- >>> reviews _left isRight "mustard"+-- False+--+-- Usually this function is used in the @(->)@ monad with a 'Simple' 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of+-- it as having one of these more restricted type signatures:+--+-- @+-- 'reviews' :: 'Simple' 'Iso' s a -> (s -> r) -> a -> r+-- 'reviews' :: 'Simple' 'Prism' s a -> (s -> r) -> a -> r+-- @+--+-- However, when working with a monad transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of+-- these more slightly more liberal type signatures may be beneficial to think of it as having:+--+-- @+-- 'reviews' :: 'MonadReader' a m => 'Simple' 'Iso' s a -> (s -> r) -> m r+-- 'reviews' :: 'MonadReader' a m => 'Simple' 'Prism' s a -> (s -> r) -> m r+-- @+reviews :: MonadReader b m => APrism s t a b -> (t -> r) -> m r+reviews Prismoid f = asks f+reviews (Prism bt _) f = asks (f . bt)+{-# INLINE reviews #-}++-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' a value (or the current environment) through it the other way.+--+-- @'reuse' ≡ 'use' '.' 'remit'@+--+-- >>> evalState (reuse _left) 5+-- Left 5+--+-- @+-- 'reuse' :: 'MonadState' a m => 'Simple' 'Prism' s a -> m s+-- 'reuse' :: 'MonadState' a m => 'Simple' 'Iso' s a -> m s+-- @+reuse :: MonadState b m => APrism s t a b -> m t+reuse Prismoid = get+reuse (Prism bt _) = gets bt+{-# INLINE reuse #-}++-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' the current state through it the other way,+-- applying a function.+--+-- @'reuses' ≡ 'uses' '.' 'remit'@+--+-- >>> evalState (reuses _left isLeft) (5 :: Int)+-- True+--+-- @+-- 'reuses' :: 'MonadState' a m => 'Simple' 'Prism' s a -> (s -> r) -> m r+-- 'reuses' :: 'MonadState' a m => 'Simple' 'Iso' s a -> (s -> r) -> m r+-- @+reuses :: MonadState b m => APrism s t a b -> (t -> r) -> m r+reuses Prismoid f = gets f+reuses (Prism bt _) f = gets (f . bt)+{-# INLINE reuses #-}++------------------------------------------------------------------------------+-- Common Prisms+------------------------------------------------------------------------------++-- | This prism provides a traversal for tweaking the left-hand value of an 'Either':+--+-- >>> over _left (+1) (Left 2)+-- Left 3+--+-- >>> over _left (+1) (Right 2)+-- Right 2+--+-- >>> Right 42 ^._left :: String+-- ""+--+-- >>> Left "hello" ^._left+-- "hello"+--+-- It also can be turned around to obtain the embedding into the 'Left' half of an 'Either':+--+-- >>> 5^.remit _left+-- Left 5+_left :: Prism (Either a c) (Either b c) a b+_left = prism Left $ either Right (Left . Right)+{-# INLINE _left #-}++-- | This prism provides a traversal for tweaking the right-hand value of an 'Either':+--+-- >>> over _right (+1) (Left 2)+-- Left 2+--+-- >>> over _right (+1) (Right 2)+-- Right 3+--+-- >>> Right "hello" ^._right+-- "hello"+--+-- >>> Left "hello" ^._right :: [Double]+-- []+--+-- It also can be turned around to obtain the embedding into the 'Right' half of an 'Either':+--+-- >>> 5^.remit _right+-- Right 5+--+-- (Unfortunately the instance for+-- @'Data.Traversable.Traversable' ('Either' c)@ is still missing from base,+-- so this can't just be 'Data.Traversable.traverse'.)+_right :: Prism (Either c a) (Either c b) a b+_right = prism Right $ left Left+{-# INLINE _right #-}++-- | This prism provides a traversal for tweaking the target of the value of 'Just' in a 'Maybe'.+--+-- >>> over _just (+1) (Just 2)+-- Just 3+--+-- Unlike 'traverse' this is a 'Prism', and so you can use it to inject as well:+--+-- >>> 5^.remit _just+-- Just 5+_just :: Prism (Maybe a) (Maybe b) a b+_just = prism Just $ maybe (Left Nothing) Right
− src/Control/Lens/Projection.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}----------------------------------------------------------------------------------- |--- Module : Control.Lens.Projection--- Copyright : (C) 2012 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : non-portable------------------------------------------------------------------------------------module Control.Lens.Projection- ( Projection- , Projective(..)- , project- , by- , Project(..)- , projection- , stereo- , mirror- -- * Simple- , SimpleProjection- ) where--import Control.Applicative-import Control.Lens.Type-import Control.Lens.Getter-import Data.Functor.Identity-import Control.Lens.Iso---- | A 'Projection' is a 'Traversal' that can also be turned around with 'by' to obtain a 'Getter'-type Projection s t a b = forall k f. (Projective k s b, Applicative f) => k (a -> f b) (s -> f s)---- | Used to provide overloading of projections.-class Projective k a d where- projective :: (d -> a) -> (x -> y) -> k x y--instance Projective (->) a d where- projective _ x = x---- | A concrete 'Projection', suitable for storing in a container or extracting an embedding.-data Project s b x y = Project (b -> s) (x -> y)---- | Compose projections.-stereo :: Projective k s a => Project t a y z -> Project s t x y -> k x z-stereo (Project g f) (Project i h) = projective (i.g) (f.h)--instance (s ~ s', b ~ b') => Projective (Project s b) s' b' where- projective = Project---- | Reflect a 'Projection'.-project :: Projective k s b => Overloaded (Project s b) f s s a b -> Overloaded k f s s a b-project (Project f g) = projective f g---- | Turn a 'Projection' around to get an embedding-by :: Project s b (b -> Identity b) (s -> Identity s) -> Getter b s-by (Project g _) = to g---- | Build a 'Projection'-projection :: (b -> s) -> (s -> Maybe a) -> Projection s t a b-projection bs sma = projective bs (\afb a -> maybe (pure a) (fmap bs . afb) (sma a))---- | Convert an 'Iso' to a 'Projection'.------ Ideally we would be able to use an 'Iso' directly as a 'Projection', but this opens a can of worms.-mirror :: Projective k s a => Simple Iso s a -> Simple Projection s a-mirror l = projection (^.from l) (\a -> Just (a^.l))---- | @type 'SimpleProjection' = 'Simple' 'Projection'@-type SimpleProjection s a = Projection s s a a
src/Control/Lens/Representable.hs view
@@ -88,15 +88,14 @@ import Control.Applicative import Control.Lens.Classes import Control.Lens.Getter-import Control.Lens.Indexed import Control.Lens.IndexedFold import Control.Lens.IndexedLens import Control.Lens.IndexedSetter import Control.Lens.IndexedTraversal import Control.Lens.Internal import Control.Lens.Internal.Combinators-import Control.Lens.Iso import Control.Lens.Type+import Control.Lens.Wrapped import Data.Foldable as Foldable import Data.Functor.Identity import Data.Monoid@@ -124,7 +123,7 @@ rep :: (Rep f -> a) -> f a instance Representable Identity where- rep f = Identity (f (from identity))+ rep f = Identity (f (unwrapping Identity)) -- | NB: The 'Eq' requirement on this instance is a consequence of the choice of 'Lens' as a 'Rep', it isn't fundamental. instance Eq e => Representable ((->) e) where@@ -232,7 +231,7 @@ -- | A version of 'rep' that is an isomorphism. Predicativity requires that -- we wrap the 'Rep' as a 'Key', however. tabulated :: Representable f => (Path f -> a) -> f a-tabulated = isomorphic (\f -> rep (f . Path)) (\fa path -> view (walk path) fa)+tabulated f = rep (f . Path) {-# INLINE tabulated #-} -----------------------------------------------------------------------------@@ -303,15 +302,15 @@ -- | An 'IndexedSetter' that walks an 'Representable' 'Functor' using a 'Path' for an index. rmapped :: Representable f => IndexedSetter (Path f) (f a) (f b) a b-rmapped = index $ \f -> tainted# (rmap (\i -> untainted# (f (Path i))))+rmapped = indexed $ \f -> tainted# (rmap (\i -> untainted# (f (Path i)))) {-# INLINE rmapped #-} -- | An 'IndexedFold' that walks an 'Foldable' 'Representable' 'Functor' using a 'Path' for an index. rfolded :: (Representable f, Foldable f) => IndexedFold (Path f) (f a) a-rfolded = index $ \f -> coerce . getFolding . rfoldMap (\i -> folding# (f (Path i)))+rfolded = indexed $ \f -> coerce . getFolding . rfoldMap (\i -> folding# (f (Path i))) {-# INLINE rfolded #-} -- | An 'IndexedTraversal' for a 'Traversable' 'Representable' 'Functor'. rtraversed :: (Representable f, Traversable f) => IndexedTraversal (Path f) (f a) (f b) a b-rtraversed = index $ \ f -> sequenceA . rmap (f . Path)+rtraversed = indexed $ \ f -> sequenceA . rmap (f . Path) {-# INLINE rtraversed #-}
src/Control/Lens/Setter.hs view
@@ -36,12 +36,14 @@ , mapOf , set , (.~), (%~)- , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (&&~), (<.~), (?~), (<?~)+ , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (<?~) -- * State Combinators , assign , (.=), (%=)- , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (&&=), (<.=), (?=), (<?=)+ , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (&&=), (<.=), (?=), (<?=) , (<~)+ -- * Simplified State Setting+ , set' -- * Storing Setters , ReifiedSetter(..) -- * Setter Internals@@ -60,12 +62,27 @@ import Control.Lens.Internal.Combinators import Control.Monad (liftM) import Control.Monad.State.Class as State+import Data.Monoid -- $setup -- >>> import Control.Lens+-- >>> import Control.Monad.State+-- >>> import Data.Map as Map+-- >>> import Debug.SimpleReflect.Expr as Expr+-- >>> import Debug.SimpleReflect.Vars as Vars+-- >>> let f :: Expr -> Expr; f = Vars.f+-- >>> let g :: Expr -> Expr; g = Vars.g+-- >>> let h :: Expr -> Expr -> Expr; h = Vars.h+-- >>> let getter :: Expr -> Expr; getter = fun "getter"+-- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -infixr 4 .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, ||~, %~, <.~, ?~, <?~-infix 4 .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, ||=, %=, <.=, ?=, <?=+-- This would be nice to have for the Monoid examples, but adding data types or+-- instances causes doctest on Travis-CI to flip out.+--+-- >>> instance Monoid Expr where mappend = Expr.op InfixR 6 "<>"; mempty = var "mempty"++infixr 4 .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, <?~+infix 4 .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, <.=, ?=, <?= infixr 2 <~ ------------------------------------------------------------------------------@@ -86,6 +103,7 @@ -- 'over' l f '.' 'over' l g ≡ 'over' l (f '.' g) -- @ --+-- -- These an be stated more directly: -- -- @@@ -95,6 +113,21 @@ -- -- You can compose a 'Setter' with a 'Control.Lens.Type.Lens' or a 'Control.Lens.Traversal.Traversal' using ('.') from the Prelude -- and the result is always only a 'Setter' and nothing more.+--+-- >>> over traverse f [a,b,c,d]+-- [f a,f b,f c,f d]+--+-- >>> over _1 f (a,b)+-- (f a,b)+--+-- >>> over (traverse._1) f [(a,b),(c,d)]+-- [(f a,b),(f c,d)]+--+-- >>> over both f (a,b)+-- (f a,f b)+--+-- >>> over (traverse.both) f [(a,b),(c,d)]+-- [(f a,f b),(f c,f d)] type Setter s t a b = forall f. Settable f => (a -> f b) -> s -> f t -- |@@ -137,14 +170,17 @@ -- ('<$') ≡ 'set' 'mapped' -- @ --+-- >>> over mapped f [a,b,c]+-- [f a,f b,f c]+-- -- >>> over mapped (+1) [1,2,3] -- [2,3,4] ----- >>> set mapped () [1,2,3]--- [(),(),()]+-- >>> set mapped x [a,b,c]+-- [x,x,x] ----- >>> mapped.mapped %~ (+1) $ [[1,2],[3]]--- [[2,3],[4]]+-- >>> [[a,b],[c]] & mapped.mapped +~ x+-- [[a + x,b + x],[c + x]] -- -- >>> over (mapped._2) length [("hello","world"),("leaders","!!!")] -- [("hello",5),("leaders",3)]@@ -161,8 +197,11 @@ -- 'liftM' ≡ 'over' 'lifted' -- @ ----- >>> over lifted (+1) [1,2,3]--- [2,3,4]+-- >>> over lifted f [a,b,c]+-- [f a,f b,f c]+--+-- >>> set lifted b (Just a)+-- Just b lifted :: Monad m => Setter (m a) (m b) a b lifted = sets liftM {-# INLINE lifted #-}@@ -203,49 +242,40 @@ -- 'over' '.' 'sets' ≡ 'id' -- @ --+-- Given any valid 'Setter' @l@, you can also rely on the law:+--+-- @'over' l f . 'over' l g = 'over' l (f . g)@+--+-- /e.g./+--+-- >>> over mapped f (over mapped g [a,b,c]) == over mapped (f . g) [a,b,c]+-- True+--+-- Another way to view 'over' is to say that it transforms a 'Setter' into a+-- \"semantic editor combinator\".+--+-- >>> over mapped f (Just a)+-- Just (f a)+-- -- >>> over mapped (*10) [1,2,3] -- [10,20,30] --+-- >>> over _1 f (a,b)+-- (f a,b)+-- -- >>> over _1 show (10,20) -- ("10",20) ----- Another way to view 'over' is to say that it transformers a 'Setter' into a--- \"semantic editor combinator\".--- -- @'over' :: 'Setter' s t a b -> (a -> b) -> s -> t@ over :: Setting s t a b -> (a -> b) -> s -> t over l f = runMutator# (l (mutator# f)) {-# INLINE over #-} --- | Modify the target of a 'Control.Lens.Type.Lens' or all the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal'--- with a function. This is an alias for 'over' that is provided for consistency.------ @--- 'mapOf' ≡ 'over'--- 'fmap' ≡ 'mapOf' 'mapped'--- 'fmapDefault' ≡ 'mapOf' 'traverse'--- 'sets' '.' 'mapOf' ≡ 'id'--- 'mapOf' '.' 'sets' ≡ 'id'--- @------ >>> mapOf mapped (+1) [1,2,3,4]--- [2,3,4,5]------ >>> mapOf _1 (+1) (1,2)--- (2,2)------ >>> mapOf both (+1) (1,2)--- (2,3)------ @--- 'mapOf' :: 'Setter' s t a b -> (a -> b) -> s -> t--- 'mapOf' :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> t--- 'mapOf' :: 'Control.Lens.Type.Lens' s t a b -> (a -> b) -> s -> t--- 'mapOf' :: 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> t--- @+-- | 'mapOf' is a deprecated alias for 'over'. mapOf :: Setting s t a b -> (a -> b) -> s -> t mapOf = over {-# INLINE mapOf #-}+{-# DEPRECATED mapOf "Use `over`" #-} -- | Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' -- or 'Control.Lens.Traversal.Traversal' with a constant value.@@ -271,6 +301,34 @@ set l b = runMutator# (l (\_ -> Mutator b)) {-# INLINE set #-} +-- |+-- Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Control.Lens.Type.Simple' 'Setter'+-- or 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' with a constant value, without changing its type.+--+-- This is a type restricted version of 'set', which retains the type of the original.+--+-- >>> set' mapped x [a,b,c,d]+-- [x,x,x,x]+--+-- >>> set' _2 "hello" (1,"world")+-- (1,"hello")+--+-- >>> set' mapped 0 [1,2,3,4]+-- [0,0,0,0]+--+-- Note: Attempting to adjust 'set'' a 'Fold' or 'Getter' will fail at compile time with an+-- relatively nice error message.+--+-- @+-- 'set'' :: 'Control.Lens.Type.Simple' 'Setter' s a -> a -> s -> s+-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> s+-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> a -> s -> s+-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> s+-- @+set' :: Setting s s a a -> a -> s -> s+set' l b = runMutator# (l (\_ -> Mutator b))+{-# INLINE set' #-}+ -- | Modifies the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or -- 'Control.Lens.Traversal.Traversal' with a user supplied function. --@@ -281,14 +339,20 @@ -- 'Data.Traversable.fmapDefault' f ≡ 'traverse' '%~' f -- @ --+-- >>> (a,b,c) & _3 %~ f+-- (a,b,f c)+--+-- >>> (a,b) & both %~ f+-- (f a,f b)+-- -- >>> _2 %~ length $ (1,"hello") -- (1,5) ----- >>> traverse %~ (+1) $ [1,2,3]--- [2,3,4]+-- >>> traverse %~ f $ [a,b,c]+-- [f a,f b,f c] ----- >>> _2 %~ (+1) $ (3,4)--- (3,5)+-- >>> traverse %~ even $ [1,2,3]+-- [False,True,False] -- -- >>> traverse.traverse %~ length $ [["hello","world"],["!!!"]] -- [[5,5],[3]]@@ -310,9 +374,15 @@ -- -- @f '<$' a ≡ 'mapped' '.~' f '$' a@ ----- >>> _1 .~ "hello" $ (42,"world")+-- >>> (a,b,c,d) & _4 .~ e+-- (a,b,c,e)+--+-- >>> (42,"world") & _1 .~ "hello" -- ("hello","world") --+-- >>> (a,b) & both .~ c+-- (c,c)+-- -- @ -- ('.~') :: 'Setter' s t a b -> b -> s -> t -- ('.~') :: 'Control.Lens.Iso.Iso' s t a b -> b -> s -> t@@ -327,6 +397,12 @@ -- -- @l '?~' t ≡ 'set' l ('Just' t)@ --+-- >>> Nothing & id ?~ a+-- Just a+--+-- >>> Map.empty & at 3 ?~ x+-- fromList [(3,x)]+-- -- @ -- ('?~') :: 'Setter' s t a ('Maybe' b) -> b -> s -> t -- ('?~') :: 'Control.Lens.Iso.Iso' s t a ('Maybe' b) -> b -> s -> t@@ -343,11 +419,13 @@ -- -- If you do not need a copy of the intermediate result, then using @l '.~' t@ directly is a good idea. ----- >>> _3 <.~ "world" $ ("good","morning","vietnam")+-- >>> (a,b) & _1 <.~ c+-- (c,(c,b))+--+-- >>> ("good","morning","vietnam") & _3 <.~ "world" -- ("world",("good","morning","world")) ----- >>> import Data.Map as Map--- >>> _2.at "hello" <.~ Just "world" $ (42,Map.fromList [("goodnight","gracie")])+-- >>> (42,Map.fromList [("goodnight","gracie")]) & _2.at "hello" <.~ Just "world" -- (Just "world",(42,fromList [("goodnight","gracie"),("hello","world")])) -- -- @@@ -382,12 +460,18 @@ -- | Increment the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' ----- >>> _1 +~ 1 $ (1,2)--- (2,2)+-- >>> (a,b) & _1 +~ c+-- (a + c,b) ----- >>> both +~ 2 $ (5,6)--- (7,8)+-- >>> (a,b) & both +~ c+-- (a + c,b + c) --+-- >>> (1,2) & _2 +~ 1+-- (1,3)+--+-- >>> [(a,b),(c,d)] & traverse.both +~ e+-- [(a + e,b + e),(c + e,d + e)]+-- -- @ -- ('+~') :: Num a => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> s -> s -- ('+~') :: Num a => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> s@@ -400,10 +484,16 @@ -- | Multiply the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' ----- >>> _2 *~ 4 $ (1,2)+-- >>> (a,b) & _1 *~ c+-- (a * c,b)+--+-- >>> (a,b) & both *~ c+-- (a * c,b * c)+--+-- >>> (1,2) & _2 *~ 4 -- (1,8) ----- >>> mapped *~ 2 $ Just 24+-- >>> Just 24 & mapped *~ 2 -- Just 48 -- -- @@@ -418,6 +508,12 @@ -- | Decrement the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' --+-- >>> (a,b) & _1 -~ c+-- (a - c,b)+--+-- >>> (a,b) & both -~ c+-- (a - c,b - c)+-- -- >>> _1 -~ 2 $ (1,2) -- (-1,2) --@@ -436,7 +532,13 @@ -- | Divide the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' ----- >>> _2 //~ 2 $ ("Hawaii",10)+-- >>> (a,b) & _1 //~ c+-- (a / c,b)+--+-- >>> (a,b) & both //~ c+-- (a / c,b / c)+--+-- >>> ("Hawaii",10) & _2 //~ 2 -- ("Hawaii",5.0) -- -- @@@ -450,7 +552,7 @@ -- | Raise the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to a non-negative integral power ----- >>> _2 ^~ 2 $ (1,3)+-- >>> (1,3) & _2 ^~ 2 -- (1,9) -- -- @@@ -465,7 +567,7 @@ -- | Raise the target(s) of a fractionally valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an integral power ----- >>> _2 ^^~ (-1) $ (1,2)+-- >>> (1,2) & _2 ^^~ (-1) -- (1,0.5) -- -- @@@ -481,6 +583,12 @@ -- | Raise the target(s) of a floating-point valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an arbitrary power. --+-- >>> (a,b) & _1 **~ c+-- (a**c,b)+--+-- >>> (a,b) & both **~ c+-- (a**c,b**c)+-- -- >>> _2 **~ pi $ (1,3) -- (1,31.54428070019754) --@@ -539,6 +647,12 @@ -- -- This is an alias for ('.='). --+-- >>> execState (do assign _1 c; assign _2 d) (a,b)+-- (c,d)+--+-- >>> execState (both .= c) (a,b)+-- (c,c)+-- -- @ -- 'assign' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () -- 'assign' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> a -> m ()@@ -554,6 +668,12 @@ -- -- This is an infix version of 'assign'. --+-- >>> execState (do _1 .= c; _2 .= d) (a,b)+-- (c,d)+--+-- >>> execState (both .= c) (a,b)+-- (c,c)+-- -- @ -- ('.=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () -- ('.=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> a -> m ()@@ -568,6 +688,12 @@ -- | Map over the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' in our monadic state. --+-- >>> execState (do _1 %= f;_2 %= g) (a,b)+-- (f a,g b)+--+-- >>> execState (do both %= f) (a,b)+-- (f a,f b)+-- -- @ -- ('%=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m () -- ('%=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> a) -> m ()@@ -581,6 +707,12 @@ -- | Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' in our monadic -- state with 'Just' a new value, irrespective of the old. --+-- >>> execState (do at 1 ?= a; at 2 ?= b) Map.empty+-- fromList [(1,a),(2,b)]+--+-- >>> execState (do _1 ?= b; _2 ?= c) (Just a, Nothing)+-- (Just b,Just c)+-- -- @ -- ('?=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s ('Maybe' a) -> a -> m () -- ('?=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s ('Maybe' a) -> a -> m ()@@ -602,6 +734,12 @@ -- 'use' 'id' -- @ --+-- >>> execState (do _1 += c; _2 += d) (a,b)+-- (a + c,b + d)+--+-- >>> execState (do _1.at 1.non 0 += 10) (Map.fromList [(2,100)],"hello")+-- (fromList [(1,10),(2,100)],"hello")+-- -- @ -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m ()@@ -614,6 +752,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by subtracting a value --+-- >>> execState (do _1 -= c; _2 -= d) (a,b)+-- (a - c,b - d)+-- -- @ -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m ()@@ -626,6 +767,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by multiplying by value. --+-- >>> execState (do _1 *= c; _2 *= d) (a,b)+-- (a * c,b * d)+-- -- @ -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m ()@@ -638,6 +782,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by dividing by a value. --+-- >>> execState (do _1 //= c; _2 //= d) (a,b)+-- (a / c,b / d)+-- -- @ -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m ()@@ -674,6 +821,9 @@ -- | Raise the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an arbitrary power --+-- >>> execState (do _1 **= c; _2 **= d) (a,b)+-- (a**c,b**d)+-- -- @ -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m ()@@ -686,6 +836,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by taking their logical '&&' with a value --+-- >>> execState (do _1 &&= True; _2 &&= False; _3 &&= True; _4 &&= False) (True,True,False,False)+-- (True,False,False,False)+-- -- @ -- ('&&=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Setter' s 'Bool' -> 'Bool' -> m () -- ('&&=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> 'Bool' -> m ()@@ -698,6 +851,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Iso, 'Setter' or 'Control.Lens.Traversal.Traversal' by taking their logical '||' with a value --+-- >>> execState (do _1 ||= True; _2 ||= False; _3 ||= True; _4 ||= False) (True,True,False,False)+-- (True,True,True,False)+-- -- @ -- ('||=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Setter' s 'Bool' -> 'Bool' -> m () -- ('||=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> 'Bool' -> m ()@@ -776,6 +932,45 @@ l ?= b return b {-# INLINE (<?=) #-}++-- | Modify the target of a monoidally valued by 'mappend'ing another value.+--+-- >>> (Sum a,b) & _1 <>~ Sum c+-- (Sum {getSum = a + c},b)+--+-- >>> (Sum a,Sum b) & both <>~ Sum c+-- (Sum {getSum = a + c},Sum {getSum = b + c})+--+-- >>> both <>~ "!!!" $ ("hello","world")+-- ("hello!!!","world!!!")+--+-- @+-- ('<>~') :: 'Monoid' a => 'Setter' s t a a -> a -> s -> t+-- ('<>~') :: 'Monoid' a => 'Iso' s t a a -> a -> s -> t+-- ('<>~') :: 'Monoid' a => 'Lens' s t a a -> a -> s -> t+-- ('<>~') :: 'Monoid' a => 'Traversal' s t a a -> a -> s -> t+-- @+(<>~) :: Monoid a => Setting s t a a -> a -> s -> t+l <>~ n = over l (`mappend` n)+{-# INLINE (<>~) #-}++-- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value.+--+-- >>> execState (do _1 <>= Sum c; _2 <>= Product d) (Sum a,Product b)+-- (Sum {getSum = a + c},Product {getProduct = b * d})+--+-- >>> execState (both <>= "!!!") ("hello","world")+-- ("hello!!!","world!!!")+--+-- @+-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m ()+-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Iso' s a -> a -> m ()+-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Lens' s a -> a -> m ()+-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Traversal' s a -> a -> m ()+-- @+(<>=) :: (MonadState s m, Monoid a) => SimpleSetting s a -> a -> m ()+l <>= a = State.modify (l <>~ a)+{-# INLINE (<>=) #-} -- | Reify a setter so it can be stored safely in a container. newtype ReifiedSetter s t a b = ReifySetter { reflectSetter :: Setter s t a b }
src/Control/Lens/Simple.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- |
src/Control/Lens/TH.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -50,15 +50,18 @@ ) where import Control.Applicative+#if !(MIN_VERSION_template_haskell(2,7,0))+import Control.Monad (ap)+#endif+import Control.Lens.Combinators import Control.Lens.Fold import Control.Lens.Getter+import Control.Lens.IndexedLens import Control.Lens.Iso import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Type-import Control.Lens.IndexedLens-import Control.Monad import Data.Char (toLower) import Data.Either (lefts) import Data.Foldable hiding (concat)@@ -153,24 +156,24 @@ -- -- Defaults to lowercasing the first letter of the constructor. lensIso :: Simple Lens LensRules (String -> Maybe String)-lensIso f (LensRules i n c o) = (\i' -> LensRules i' n c o) <$> f i+lensIso f (LensRules i n c o) = f i <&> \i' -> LensRules i' n c o -- | Lens to access the convention for naming fields in our lens rules. -- -- Defaults to stripping the _ off of the field name, lowercasing the name, and -- rejecting the field if it doesn't start with an '_'. lensField :: Simple Lens LensRules (String -> Maybe String)-lensField f (LensRules i n c o) = (\n' -> LensRules i n' c o) <$> f n+lensField f (LensRules i n c o) = f n <&> \n' -> LensRules i n' c o -- | Retrieve options such as the name of the class and method to put in it to -- build a class around monomorphic data types. lensClass :: Simple Lens LensRules (String -> Maybe (String, String))-lensClass f (LensRules i n c o) = (\c' -> LensRules i n c' o) <$> f c+lensClass f (LensRules i n c o) = f c <&> \c' -> LensRules i n c' o -- | Retrieve options such as the name of the class and method to put in it to -- build a class around monomorphic data types. lensFlags :: Simple Lens LensRules (Set LensFlag)-lensFlags f (LensRules i n c o) = LensRules i n c <$> f o+lensFlags f (LensRules i n c o) = f o <&> LensRules i n c -- | Default lens rules defaultRules :: LensRules@@ -312,35 +315,30 @@ freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n)) makeIsoTo :: Name -> ExpQ-makeIsoTo conName = do- f <- newName "f"- a <- newName "a"- lamE [varP f, conP conName [varP a]] $- appsE [ return (VarE 'fmap)- , conE conName- , varE f `appE` varE a- ]+makeIsoTo = conE makeIsoFrom :: Name -> ExpQ makeIsoFrom conName = do- f <- newName "f"- a <- newName "a" b <- newName "b"- lamE [varP f, varP a] $- appsE [ return (VarE 'fmap)- , lamE [conP conName [varP b]] $ varE b- , varE f `appE` (conE conName `appE` varE a)- ]+ lamE [conP conName [varP b]] $ varE b makeIsoBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ makeIsoBody lensName conName f g = funD lensName [clause [] (normalB body) []] where- body = appsE [ return (VarE 'isomorphic)- , f conName+ body = appsE [ varE 'iso , g conName+ , f conName ] makeLensBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ-makeLensBody lensName conName f _ = funD lensName [clause [] (normalB (f conName)) []]+makeLensBody lensName conName i o = do+ f <- newName "f"+ a <- newName "a"+ funD lensName [clause [] (normalB (+ lamE [varP f, varP a] $+ appsE [ varE 'fmap+ , o conName+ , varE f `appE` (i conName `appE` varE a)+ ])) []] plain :: TyVarBndr -> TyVarBndr plain (KindedTV t _) = PlainTV t@@ -356,21 +354,6 @@ appsT :: TypeQ -> [TypeQ] -> TypeQ appsT = Prelude.foldl appT --- | Given------ > newtype Cxt b => Foo a b c d = Foo { _baz :: Bar a b }------ This will generate:------ > foo :: (Cxt b, Cxt f) => Iso (Foo a b c d) (Foo e f g h) (Bar a b) (Bar e f)--- > foo = isomorphic (\f a -> (\(Foo b) -> b) <$> f (Foo a))--- > (\f (Foo a) -> fmap Foo (f a))--- > {-# INLINE foo #-}---- > baz :: (Cxt b, Cxt f) => Iso (Bar a b) (Bar e f) (Foo a b c d) (Foo e f g h)--- > baz = isomorphic (\f (Foo a) -> fmap Foo (f a))--- > (\f a -> fmap (\(Foo b) -> b) (f (Foo a)))--- > {-# INLINE baz #-} makeIsoLenses :: LensRules -> Cxt -> Name@@ -462,13 +445,11 @@ -> Q [Dec] makeFieldLenses cfg ctx tyConName tyArgs0 cons = do let tyArgs = map plain tyArgs0- maybeLensClass = do- guard $ tyArgs == []- view lensClass cfg $ nameBase tyConName+ maybeLensClass = view lensClass cfg $ nameBase tyConName maybeClassName = fmap (^._1.to mkName) maybeLensClass t <- newName "t" a <- newName "a"- + --TODO: there's probably a more efficient way to do this. lensFields <- map (\xs -> (fst $ head xs, map snd xs)) . groupBy ((==) `on` fst) . sortBy (comparing fst)@@ -496,12 +477,15 @@ relevantBndr b = s^.contains (b^.name) relevantCtx = not . Set.null . Set.intersection s . setOf typeVars tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs')- ps = ctx ++ filter relevantCtx (substTypeVars m ctx)+ ps = filter relevantCtx (substTypeVars m ctx) qs = case maybeClassName of- Just n | not (cfg^.createClass) -> ClassP n [VarT t] : ps- _ -> ps- tvs' | isJust maybeClassName && not (cfg^.createClass) = PlainTV t : tvs- | otherwise = tvs+ Just n | not (cfg^.createClass) -> ClassP n [VarT t] : (ctx ++ ps)+ | otherwise -> ps+ _ -> ctx ++ ps+ tvs' = case maybeClassName of+ Just _ | not (cfg^.createClass) -> PlainTV t : tvs+ | otherwise -> []+ _ -> tvs --TODO: Better way to write this? fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields@@ -510,7 +494,7 @@ isTraversal <- do let notSingular = filter ((/= 1) . length . snd) conList- showCon (c, fs) = pprint (view name c) ++ " { " ++ concat (intersperse ", " $ map pprint fs) ++ " }"+ showCon (c, fs) = pprint (c^.name) ++ " { " ++ intercalate ", " (map pprint fs) ++ " }" case (cfg^.buildTraversals, cfg^.partialLenses) of (True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses." (False, True) -> return False@@ -528,8 +512,8 @@ --TODO: consider detecting simpleLenses, and generating signatures involving "Simple"? let decl = SigD lensName . ForallT tvs' qs- . apps (if isTraversal then ConT ''Traversal else ConT ''Lens)- $ if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty]+ . apps (ConT (if isTraversal then ''Traversal else ''Lens))+ $ if cfg^.simpleLenses || isJust maybeClassName then [aty,aty,cty,cty] else [aty,bty,cty,dty] body <- makeFieldLensBody isTraversal lensName conList maybeMethodName #ifndef INLINING@@ -544,13 +528,15 @@ Just (clsNameString, methodNameString) -> do let clsName = mkName clsNameString methodName = mkName methodNameString+ varArgs = varT . view name <$> tyArgs+ appliedCon = conT tyConName `appsT` varArgs Prelude.sequence $ filter (\_ -> cfg^.createClass) [- classD (return []) clsName [PlainTV t] [] (- sigD methodName (appsT (conT ''Lens) [varT t, varT t, conT tyConName, conT tyConName]) :+ classD (return []) clsName (PlainTV t : tyArgs) (if List.null tyArgs then [] else [FunDep [t] (view name <$> tyArgs)]) (+ sigD methodName (appsT (conT ''Lens) [varT t, varT t, appliedCon, appliedCon]) : map return defs)] ++ filter (\_ -> cfg^.createInstance) [- instanceD (return []) (conT clsName `appT` conT tyConName) [+ instanceD (return []) ((conT clsName `appT` appliedCon) `appsT` varArgs) [ funD methodName [clause [varP a] (normalB (varE a)) []] #ifdef INLINING , inlinePragma methodName@@ -562,7 +548,7 @@ getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))] getLensFields f (RecC cn fs) = return . catMaybes- $ map (\(fn,_,t) -> (\ln -> (mkName ln, (cn,fn,t))) <$> f (nameBase fn)) fs+ $ fs <&> \(fn,_,t) -> f (nameBase fn) <&> \ln -> (mkName ln, (cn,fn,t)) getLensFields _ _ = return [] @@ -575,7 +561,7 @@ unifyTypes tvs tys = return (tvs, head tys) #if !(MIN_VERSION_template_haskell(2,7,0))--- | The orphan instance for old versions is bad, but programing without 'Applicative' is worse.+-- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse. instance Applicative Q where pure = return (<*>) = ap
src/Control/Lens/Traversal.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal@@ -45,16 +47,18 @@ , unsafePartsOf , unsafePartsOf' , holesOf+ , singular+ , unsafeSingular -- * Common Traversals , Traversable(traverse)- , _left- , _right , both , beside , taking , dropping+ , loci + -- * Cloning Traversals , cloneTraversal , ReifiedTraversal(..)@@ -69,6 +73,7 @@ import Control.Applicative as Applicative import Control.Applicative.Backwards+import Control.Lens.Combinators import Control.Lens.Fold import Control.Lens.Internal import Control.Lens.Internal.Combinators@@ -255,8 +260,8 @@ -- 'mapAccumROf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumROf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @-mapAccumROf :: LensLike (Lazy.State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)-mapAccumROf l f s0 a = swap (Lazy.runState (l (\c -> State.state (\s -> swap (f s c))) a) s0)+mapAccumROf :: LensLike (Backwards (Lazy.State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)+mapAccumROf = mapAccumLOf . backwards {-# INLINE mapAccumROf #-} -- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'.@@ -270,8 +275,8 @@ -- 'mapAccumLOf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumLOf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @-mapAccumLOf :: LensLike (Backwards (Lazy.State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)-mapAccumLOf = mapAccumROf . backwards+mapAccumLOf :: LensLike (Lazy.State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)+mapAccumLOf l f acc0 s = swap (Lazy.runState (l (\a -> State.state (\acc -> swap (f acc a))) s) acc0) {-# INLINE mapAccumLOf #-} swap :: (a,b) -> (b,a)@@ -287,7 +292,7 @@ -- 'scanr1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t -- 'scanr1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t -- @-scanr1Of :: LensLike (Lazy.State (Maybe a)) s t a a -> (a -> a -> a) -> s -> t+scanr1Of :: LensLike (Backwards (Lazy.State (Maybe a))) s t a a -> (a -> a -> a) -> s -> t scanr1Of l f = snd . mapAccumROf l step Nothing where step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f a s@@ -302,12 +307,18 @@ -- 'scanr1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t -- 'scanr1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t -- @-scanl1Of :: LensLike (Backwards (Lazy.State (Maybe a))) s t a a -> (a -> a -> a) -> s -> t+scanl1Of :: LensLike (Lazy.State (Maybe a)) s t a a -> (a -> a -> a) -> s -> t scanl1Of l f = snd . mapAccumLOf l step Nothing where step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f s a {-# INLINE scanl1Of #-} +-- | This 'Traversal' allows you to 'traverse' the individual stores in a 'Bazaar'.+loci :: Traversal (Bazaar a c s) (Bazaar b c s) a b+loci f w = traverse f (ins w) <&> \xs -> Bazaar $ \g -> traverse g xs <&> unsafeOuts w+++ ------------------------------------------------------------------------------- -- Parts and Holes -------------------------------------------------------------------------------@@ -387,6 +398,40 @@ f (x:xs) g = Context (g . (:xs)) x : f xs (g . (x:)) {-# INLINE holesOf #-} +-- | This converts a 'Traversal' that you "know" will target one or more elements to a 'Lens'. It can+-- also be used to transform a non-empty 'Fold' into a 'Getter' or a non-empty 'Control.Lens.Action.MonadicFold' into an+-- 'Control.Lens.Action.Action'.+--+-- The resulting 'Lens', 'Getter', or 'Control.Lens.Action.Action' will be partial if the supplied traversal returns+-- no results.+--+-- @+-- 'singular' :: 'Traversal' s t a a -> 'Lens' s t a a+-- 'singular' :: 'Fold' s a -> 'Getter' s a+-- 'singular' :: 'Control.Lens.Action.MonadicFold' m s a -> 'Control.Lens.Action.Action' m s a+-- @+singular :: Functor f => LensLike (BazaarT a a f) s t a a -> LensLike f s t a a+singular l f = partsOf l $ \xs -> case xs of+ (a:as) -> (:as) <$> f a+ [] -> [] <$ f (error "singular: empty traversal")++-- | This converts a 'Traversal' that you "know" will target only one element to a 'Lens'. It can also be+-- used to transform a 'Fold' into a 'Getter' or a 'Control.Lens.Action.MonadicFold' into an 'Control.Lens.Action.Action'.+--+-- The resulting 'Lens', 'Getter', or 'Control.Lens.Action.Action' will be partial if the Traversal targets nothing+-- or more than one element.+--+-- @+-- 'unsafeSingular' :: 'Traversal' s t a b -> 'Lens' s t a b+-- 'unsafeSingular' :: 'Fold' s a -> 'Getter' s a+-- 'unsafeSingular' :: 'Control.Lens.Action.MonadicFold' m s a -> 'Control.Lens.Action.Action' m s a+-- @+unsafeSingular :: Functor f => LensLike (BazaarT a b f) s t a b -> LensLike f s t a b+unsafeSingular l f = unsafePartsOf l $ \xs -> case xs of+ [a] -> return <$> f a+ [] -> error "unsafeSingular: empty traversal"+ _ -> error "unsafeSingular: traversing multiple results"+ ------------------------------------------------------------------------------ -- Internal functions used by 'partsOf', 'holesOf', etc. ------------------------------------------------------------------------------@@ -447,52 +492,6 @@ beside l r f ~(s,s') = (,) <$> l f s <*> r f s' {-# INLINE beside #-} --- | A traversal for tweaking the left-hand value of an 'Either':------ >>> over _left (+1) (Left 2)--- Left 3------ >>> over _left (+1) (Right 2)--- Right 2------ >>> Right 42 ^._left :: String--- ""------ >>> Left "hello" ^._left--- "hello"------ @_left :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f ('Either' b c)@-_left :: Traversal (Either a c) (Either b c) a b-_left f (Left a) = Left <$> f a-_left _ (Right c) = pure $ Right c-{-# INLINE _left #-}---- | traverse the right-hand value of an 'Either':------ @'_right' ≡ 'Data.Traversable.traverse'@------ Unfortunately the instance for--- @'Data.Traversable.Traversable' ('Either' c)@ is still missing from base,--- so this can't just be 'Data.Traversable.traverse'------ >>> over _right (+1) (Left 2)--- Left 2------ >>> over _right (+1) (Right 2)--- Right 3------ >>> Right "hello" ^._right--- "hello"------ >>> Left "hello" ^._right :: [Double]--- []------ @_right :: 'Applicative' f => (a -> f b) -> 'Either' c a -> f ('Either' c a)@-_right :: Traversal (Either c a) (Either c b) a b-_right _ (Left c) = pure $ Left c-_right f (Right a) = Right <$> f a-{-# INLINE _right #-}- -- | Visit the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. -- -- >>> [("hello","world"),("!!!","!!!")]^.. taking 2 (traverse.both)@@ -517,7 +516,7 @@ -- >>> [1..]^? dropping 1 folded -- Just 2 dropping :: Applicative f => Int -> SimpleLensLike (Indexing f) s a -> SimpleLensLike f s a-dropping n l f s = case runIndexing (l (\a -> Indexing $ \i -> (if i >= n then f a else pure a, i + 1)) s) 0 of+dropping n l f s = case runIndexing (l (\a -> Indexing $ \i -> i `seq` (if i >= n then f a else pure a, i + 1)) s) 0 of (r, _) -> r {-# INLINE dropping #-}
src/Control/Lens/Tuple.hs view
@@ -28,8 +28,8 @@ , Field9(..) ) where +import Control.Lens.Combinators import Control.Lens.Type-import Data.Functor -- $setup -- >>> import Control.Lens@@ -67,35 +67,35 @@ -- | @'_1' k ~(a,b) = (\a' -> (a',b)) '<$>' k a@ instance Field1 (a,b) (a',b) a a' where- _1 k ~(a,b) = (\a' -> (a',b)) <$> k a+ _1 k ~(a,b) = k a <&> \a' -> (a',b) {-# INLINE _1 #-} instance Field1 (a,b,c) (a',b,c) a a' where- _1 k ~(a,b,c) = (\a' -> (a',b,c)) <$> k a+ _1 k ~(a,b,c) = k a <&> \a' -> (a',b,c) {-# INLINE _1 #-} instance Field1 (a,b,c,d) (a',b,c,d) a a' where- _1 k ~(a,b,c,d) = (\a' -> (a',b,c,d)) <$> k a+ _1 k ~(a,b,c,d) = k a <&> \a' -> (a',b,c,d) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e) (a',b,c,d,e) a a' where- _1 k ~(a,b,c,d,e) = (\a' -> (a',b,c,d,e)) <$> k a+ _1 k ~(a,b,c,d,e) = k a <&> \a' -> (a',b,c,d,e) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f) (a',b,c,d,e,f) a a' where- _1 k ~(a,b,c,d,e,f) = (\a' -> (a',b,c,d,e,f)) <$> k a+ _1 k ~(a,b,c,d,e,f) = k a <&> \a' -> (a',b,c,d,e,f) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g) (a',b,c,d,e,f,g) a a' where- _1 k ~(a,b,c,d,e,f,g) = (\a' -> (a',b,c,d,e,f,g)) <$> k a+ _1 k ~(a,b,c,d,e,f,g) = k a <&> \a' -> (a',b,c,d,e,f,g) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h) (a',b,c,d,e,f,g,h) a a' where- _1 k ~(a,b,c,d,e,f,g,h) = (\a' -> (a',b,c,d,e,f,g,h)) <$> k a+ _1 k ~(a,b,c,d,e,f,g,h) = k a <&> \a' -> (a',b,c,d,e,f,g,h) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' where- _1 k ~(a,b,c,d,e,f,g,h,i) = (\a' -> (a',b,c,d,e,f,g,h,i)) <$> k a+ _1 k ~(a,b,c,d,e,f,g,h,i) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i) {-# INLINE _1 #-} -- | Provides access to the 2nd field of a tuple@@ -121,35 +121,35 @@ -- | @'_2' k ~(a,b) = (\b' -> (a,b')) '<$>' k b@ instance Field2 (a,b) (a,b') b b' where- _2 k ~(a,b) = (\b' -> (a,b')) <$> k b+ _2 k ~(a,b) = k b <&> \b' -> (a,b') {-# INLINE _2 #-} instance Field2 (a,b,c) (a,b',c) b b' where- _2 k ~(a,b,c) = (\b' -> (a,b',c)) <$> k b+ _2 k ~(a,b,c) = k b <&> \b' -> (a,b',c) {-# INLINE _2 #-} instance Field2 (a,b,c,d) (a,b',c,d) b b' where- _2 k ~(a,b,c,d) = (\b' -> (a,b',c,d)) <$> k b+ _2 k ~(a,b,c,d) = k b <&> \b' -> (a,b',c,d) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e) (a,b',c,d,e) b b' where- _2 k ~(a,b,c,d,e) = (\b' -> (a,b',c,d,e)) <$> k b+ _2 k ~(a,b,c,d,e) = k b <&> \b' -> (a,b',c,d,e) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f) (a,b',c,d,e,f) b b' where- _2 k ~(a,b,c,d,e,f) = (\b' -> (a,b',c,d,e,f)) <$> k b+ _2 k ~(a,b,c,d,e,f) = k b <&> \b' -> (a,b',c,d,e,f) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g) (a,b',c,d,e,f,g) b b' where- _2 k ~(a,b,c,d,e,f,g) = (\b' -> (a,b',c,d,e,f,g)) <$> k b+ _2 k ~(a,b,c,d,e,f,g) = k b <&> \b' -> (a,b',c,d,e,f,g) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h) (a,b',c,d,e,f,g,h) b b' where- _2 k ~(a,b,c,d,e,f,g,h) = (\b' -> (a,b',c,d,e,f,g,h)) <$> k b+ _2 k ~(a,b,c,d,e,f,g,h) = k b <&> \b' -> (a,b',c,d,e,f,g,h) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i) (a,b',c,d,e,f,g,h,i) b b' where- _2 k ~(a,b,c,d,e,f,g,h,i) = (\b' -> (a,b',c,d,e,f,g,h,i)) <$> k b+ _2 k ~(a,b,c,d,e,f,g,h,i) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i) {-# INLINE _2 #-} -- | Provides access to the 3rd field of a tuple@@ -158,31 +158,31 @@ _3 :: Lens s t a b instance Field3 (a,b,c) (a,b,c') c c' where- _3 k ~(a,b,c) = (\c' -> (a,b,c')) <$> k c+ _3 k ~(a,b,c) = k c <&> \c' -> (a,b,c') {-# INLINE _3 #-} instance Field3 (a,b,c,d) (a,b,c',d) c c' where- _3 k ~(a,b,c,d) = (\c' -> (a,b,c',d)) <$> k c+ _3 k ~(a,b,c,d) = k c <&> \c' -> (a,b,c',d) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e) (a,b,c',d,e) c c' where- _3 k ~(a,b,c,d,e) = (\c' -> (a,b,c',d,e)) <$> k c+ _3 k ~(a,b,c,d,e) = k c <&> \c' -> (a,b,c',d,e) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f) (a,b,c',d,e,f) c c' where- _3 k ~(a,b,c,d,e,f) = (\c' -> (a,b,c',d,e,f)) <$> k c+ _3 k ~(a,b,c,d,e,f) = k c <&> \c' -> (a,b,c',d,e,f) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g) (a,b,c',d,e,f,g) c c' where- _3 k ~(a,b,c,d,e,f,g) = (\c' -> (a,b,c',d,e,f,g)) <$> k c+ _3 k ~(a,b,c,d,e,f,g) = k c <&> \c' -> (a,b,c',d,e,f,g) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h) (a,b,c',d,e,f,g,h) c c' where- _3 k ~(a,b,c,d,e,f,g,h) = (\c' -> (a,b,c',d,e,f,g,h)) <$> k c+ _3 k ~(a,b,c,d,e,f,g,h) = k c <&> \c' -> (a,b,c',d,e,f,g,h) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i) (a,b,c',d,e,f,g,h,i) c c' where- _3 k ~(a,b,c,d,e,f,g,h,i) = (\c' -> (a,b,c',d,e,f,g,h,i)) <$> k c+ _3 k ~(a,b,c,d,e,f,g,h,i) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i) {-# INLINE _3 #-} -- | Provide access to the 4th field of a tuple@@ -191,27 +191,27 @@ _4 :: Lens s t a b instance Field4 (a,b,c,d) (a,b,c,d') d d' where- _4 k ~(a,b,c,d) = (\d' -> (a,b,c,d')) <$> k d+ _4 k ~(a,b,c,d) = k d <&> \d' -> (a,b,c,d') {-# INLINE _4 #-} instance Field4 (a,b,c,d,e) (a,b,c,d',e) d d' where- _4 k ~(a,b,c,d,e) = (\d' -> (a,b,c,d',e)) <$> k d+ _4 k ~(a,b,c,d,e) = k d <&> \d' -> (a,b,c,d',e) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f) (a,b,c,d',e,f) d d' where- _4 k ~(a,b,c,d,e,f) = (\d' -> (a,b,c,d',e,f)) <$> k d+ _4 k ~(a,b,c,d,e,f) = k d <&> \d' -> (a,b,c,d',e,f) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g) (a,b,c,d',e,f,g) d d' where- _4 k ~(a,b,c,d,e,f,g) = (\d' -> (a,b,c,d',e,f,g)) <$> k d+ _4 k ~(a,b,c,d,e,f,g) = k d <&> \d' -> (a,b,c,d',e,f,g) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h) (a,b,c,d',e,f,g,h) d d' where- _4 k ~(a,b,c,d,e,f,g,h) = (\d' -> (a,b,c,d',e,f,g,h)) <$> k d+ _4 k ~(a,b,c,d,e,f,g,h) = k d <&> \d' -> (a,b,c,d',e,f,g,h) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i) (a,b,c,d',e,f,g,h,i) d d' where- _4 k ~(a,b,c,d,e,f,g,h,i) = (\d' -> (a,b,c,d',e,f,g,h,i)) <$> k d+ _4 k ~(a,b,c,d,e,f,g,h,i) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i) {-# INLINE _4 #-} -- | Provides access to the 5th field of a tuple@@ -220,23 +220,23 @@ _5 :: Lens s t a b instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where- _5 k ~(a,b,c,d,e) = (\e' -> (a,b,c,d,e')) <$> k e+ _5 k ~(a,b,c,d,e) = k e <&> \e' -> (a,b,c,d,e') {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f) (a,b,c,d,e',f) e e' where- _5 k ~(a,b,c,d,e,f) = (\e' -> (a,b,c,d,e',f)) <$> k e+ _5 k ~(a,b,c,d,e,f) = k e <&> \e' -> (a,b,c,d,e',f) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g) (a,b,c,d,e',f,g) e e' where- _5 k ~(a,b,c,d,e,f,g) = (\e' -> (a,b,c,d,e',f,g)) <$> k e+ _5 k ~(a,b,c,d,e,f,g) = k e <&> \e' -> (a,b,c,d,e',f,g) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h) (a,b,c,d,e',f,g,h) e e' where- _5 k ~(a,b,c,d,e,f,g,h) = (\e' -> (a,b,c,d,e',f,g,h)) <$> k e+ _5 k ~(a,b,c,d,e,f,g,h) = k e <&> \e' -> (a,b,c,d,e',f,g,h) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e',f,g,h,i) e e' where- _5 k ~(a,b,c,d,e,f,g,h,i) = (\e' -> (a,b,c,d,e',f,g,h,i)) <$> k e+ _5 k ~(a,b,c,d,e,f,g,h,i) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i) {-# INLINE _5 #-} -- | Provides access to the 6th element of a tuple@@ -245,19 +245,19 @@ _6 :: Lens s t a b instance Field6 (a,b,c,d,e,f) (a,b,c,d,e,f') f f' where- _6 k ~(a,b,c,d,e,f) = (\f' -> (a,b,c,d,e,f')) <$> k f+ _6 k ~(a,b,c,d,e,f) = k f <&> \f' -> (a,b,c,d,e,f') {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g) (a,b,c,d,e,f',g) f f' where- _6 k ~(a,b,c,d,e,f,g) = (\f' -> (a,b,c,d,e,f',g)) <$> k f+ _6 k ~(a,b,c,d,e,f,g) = k f <&> \f' -> (a,b,c,d,e,f',g) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f',g,h) f f' where- _6 k ~(a,b,c,d,e,f,g,h) = (\f' -> (a,b,c,d,e,f',g,h)) <$> k f+ _6 k ~(a,b,c,d,e,f,g,h) = k f <&> \f' -> (a,b,c,d,e,f',g,h) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f',g,h,i) f f' where- _6 k ~(a,b,c,d,e,f,g,h,i) = (\f' -> (a,b,c,d,e,f',g,h,i)) <$> k f+ _6 k ~(a,b,c,d,e,f,g,h,i) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i) {-# INLINE _6 #-} -- | Provide access to the 7th field of a tuple@@ -266,15 +266,15 @@ _7 :: Lens s t a b instance Field7 (a,b,c,d,e,f,g) (a,b,c,d,e,f,g') g g' where- _7 k ~(a,b,c,d,e,f,g) = (\g' -> (a,b,c,d,e,f,g')) <$> k g+ _7 k ~(a,b,c,d,e,f,g) = k g <&> \g' -> (a,b,c,d,e,f,g') {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g',h) g g' where- _7 k ~(a,b,c,d,e,f,g,h) = (\g' -> (a,b,c,d,e,f,g',h)) <$> k g+ _7 k ~(a,b,c,d,e,f,g,h) = k g <&> \g' -> (a,b,c,d,e,f,g',h) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g',h,i) g g' where- _7 k ~(a,b,c,d,e,f,g,h,i) = (\g' -> (a,b,c,d,e,f,g',h,i)) <$> k g+ _7 k ~(a,b,c,d,e,f,g,h,i) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i) {-# INLINE _7 #-} -- | Provide access to the 8th field of a tuple@@ -283,11 +283,11 @@ _8 :: Lens s t a b instance Field8 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h') h h' where- _8 k ~(a,b,c,d,e,f,g,h) = (\h' -> (a,b,c,d,e,f,g,h')) <$> k h+ _8 k ~(a,b,c,d,e,f,g,h) = k h <&> \h' -> (a,b,c,d,e,f,g,h') {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h',i) h h' where- _8 k ~(a,b,c,d,e,f,g,h,i) = (\h' -> (a,b,c,d,e,f,g,h',i)) <$> k h+ _8 k ~(a,b,c,d,e,f,g,h,i) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i) {-# INLINE _8 #-} -- | Provides access to the 9th field of a tuple@@ -296,5 +296,5 @@ _9 :: Lens s t a b instance Field9 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i') i i' where- _9 k ~(a,b,c,d,e,f,g,h,i) = (\i' -> (a,b,c,d,e,f,g,h,i')) <$> k i+ _9 k ~(a,b,c,d,e,f,g,h,i) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i') {-# INLINE _9 #-}
src/Control/Lens/Type.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}@@ -50,6 +49,9 @@ -- The lens laws follow from this property and the desire for it to act like -- a 'Data.Traversable.Traversable' when used as a -- 'Control.Lens.Traversal.Traversal'.+--+-- In the examples below, 'getter' and 'setter' are supplied as example getters+-- and setters, and are not actual functions supplied by this package. ------------------------------------------------------------------------------- module Control.Lens.Type (@@ -61,21 +63,23 @@ , (%%~) , (%%=) + -- * Lateral Composition , choosing , chosen , alongside+ , inside -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (<//~) , (<^~), (<^^~), (<**~)- , (<||~), (<&&~)+ , (<||~), (<&&~), (<<>~) , (<<%~), (<<.~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (<//=) , (<^=), (<^^=), (<**=)- , (<||=), (<&&=)+ , (<||=), (<&&=), (<<>=) , (<<%=), (<<.=) , (<<~) @@ -83,6 +87,10 @@ , cloneLens , ReifiedLens(..) + -- * Context+ , Context(..)+ , locus+ -- * Simplified and In-Progress , LensLike , Overloaded@@ -90,22 +98,29 @@ , SimpleLensLike , SimpleOverloaded , SimpleReifiedLens-- -- * Exposed Implementation Details- , Context(..) ) where -import Control.Applicative as Applicative-import Control.Lens.Internal-import Control.Monad.State as State+import Control.Applicative+import Control.Comonad.Store as Store+import Control.Lens.Combinators ((<&>))+import Control.Lens.Internal (Context(..))+import Control.Monad.State as State+import Data.Monoid (Monoid(mappend)) -- $setup -- >>> import Control.Lens+-- >>> import Debug.SimpleReflect.Expr+-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h)+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g+-- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h+-- >>> let getter :: Expr -> Expr; getter = fun "getter"+-- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixr 4 %%~ infix 4 %%=-infixr 4 <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <%~, <<%~, <<.~-infix 4 <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <%=, <<%=, <<.=+infixr 4 <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~+infix 4 <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.= infixr 2 <<~ -------------------------------------------------------------------------------@@ -178,6 +193,15 @@ -- | Build a 'Lens' from a getter and a setter. -- -- @'lens' :: 'Functor' f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t@+--+-- >>> s ^. lens getter setter+-- getter s+--+-- >>> s & lens getter setter .~ b+-- setter s b+--+-- >>> s & lens getter setter %~ f+-- setter s (f (getter s)) lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-}@@ -240,6 +264,9 @@ -- 'Control.Lens.Traversal.Traversal' in the current state, extracting extra -- information of type @r@ and return a monoidal summary of the changes. --+-- >>> runState (_1 %%= \x -> (f x, g x)) (a,b)+-- (f a,(g a,b))+-- -- @('%%=') ≡ ('state' '.')@ -- -- It may be useful to think of ('%%='), instead, as having either of the@@ -265,6 +292,13 @@ -- Common Lenses ------------------------------------------------------------------------------- +-- | Lift a 'Lens' so it can run under a function.+--+inside :: LensLike (Context a b) s t a b -> Lens (e -> s) (e -> t) (e -> a) (e -> b)+inside l f es = o <$> f i where+ i e = case l (Context id) (es e) of Context _ a -> a+ o ea e = case l (Context id) (es e) of Context k _ -> k (ea e)+ -- | Merge two lenses, getters, setters, folds or traversals. -- -- @'chosen' ≡ 'choosing' 'id' 'id'@@@ -288,12 +322,17 @@ -- -- @'chosen' ≡ 'choosing' 'id' 'id'@ ----- >>> Left 12^.chosen--- 12+-- >>> Left a^.chosen+-- a+--+-- >>> Right a^.chosen+-- a+-- -- >>> Right "hello"^.chosen -- "hello"--- >>> chosen *~ 10 $ Right 2--- Right 20+--+-- >>> Right a & chosen *~ b+-- Right (a * b) chosen :: Lens (Either a a) (Either b b) a b chosen f (Left a) = Left <$> f a chosen f (Right a) = Right <$> f a@@ -301,15 +340,37 @@ -- | 'alongside' makes a 'Lens' from two other lenses. --+-- >>> (Left a, Right b)^.alongside chosen chosen+-- (a,b)+--+-- >>> (Left a, Right b) & alongside chosen chosen .~ (c,d)+-- (Left c,Right d)+-- -- @'alongside' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b')@ alongside :: LensLike (Context a b) s t a b -> LensLike (Context a' b') s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') alongside l r f (s, s') = case l (Context id) s of Context bt a -> case r (Context id) s' of- Context bt' a' -> (\(b,b') -> (bt b, bt' b')) <$> f (a,a')+ Context bt' a' -> f (a,a') <&> \(b,b') -> (bt b, bt' b') {-# INLINE alongside #-} +-- | This 'Lens' lets you 'view' the current 'pos' of any 'Store'+-- 'Comonad' and 'seek' to a new position. This reduces the API+-- for working with a 'ComonadStore' instances to a single 'Lens'.+--+-- @+-- 'pos' w ≡ w '^.' 'locus'+-- 'seek' s w ≡ w '&' 'locus' '.~' s+-- 'seeks' f w ≡ w '&' 'locus' '%~' f+-- @+--+-- @+-- 'locus' :: Simple Lens ('Context' s s a) s+-- @+locus :: ComonadStore s w => Simple Lens (w a) s+locus f w = (`seek` w) <$> f (pos w)+ ------------------------------------------------------------------------------- -- Cloning Lenses -------------------------------------------------------------------------------@@ -321,7 +382,9 @@ -- -- Note: This only accepts a proper 'Lens'. ----- /\"Costate Comonad Coalgebra is equivalent of Java's member variable update technology for Haskell\"/ -- \@PLT_Borat on Twitter+-- > :t let example l x = set (cloneLens l) (x^.cloneLens l + 1) x in example+-- > let example l x = set (cloneLens l) (x^.cloneLens l + 1) x in example+-- > :: Num b => LensLike (Context b b) s t b b -> s -> t cloneLens :: Functor f => LensLike (Context a b) s t a b -> (a -> f b) -> s -> f t@@ -509,7 +572,7 @@ -- @ -- ('<%=') :: 'MonadState' s m => 'Simple' 'Lens' s a -> (a -> a) -> m a -- ('<%=') :: 'MonadState' s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m a--- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Traveral' s a -> (a -> a) -> m a+-- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Traversal' s a -> (a -> a) -> m a -- @ (<%=) :: MonadState s m => LensLike ((,)b) s s a b -> (a -> b) -> m b l <%= f = l %%= \a -> let b = f a in (b,b)@@ -647,7 +710,7 @@ -- @ -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Lens' s a -> (a -> a) -> m a -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m a--- ('<<%=') :: ('MonadState' s m, 'Monoid' b) => 'Simple' 'Traveral' s a -> (a -> a) -> m a+-- ('<<%=') :: ('MonadState' s m, 'Monoid' b) => 'Simple' 'Traversal' s a -> (a -> a) -> m a -- @ (<<%=) :: MonadState s m => LensLike ((,)a) s s a b -> (a -> b) -> m a l <<%= f = l %%= \a -> (a, f a)@@ -664,7 +727,7 @@ -- @ -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Lens' s a -> (a -> a) -> m a -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m a--- ('<<%=') :: ('MonadState' s m, 'Monoid' t) => 'Simple' 'Traveral' s a -> (a -> a) -> m a+-- ('<<%=') :: ('MonadState' s m, 'Monoid' t) => 'Simple' 'Traversal' s a -> (a -> a) -> m a -- @ (<<.=) :: MonadState s m => LensLike ((,)a) s s a b -> b -> m a l <<.= b = l %%= \a -> (a,b)@@ -685,6 +748,23 @@ modify $ \s -> case l (Context id) s of Context f _ -> f b return b {-# INLINE (<<~) #-}++-- | 'mappend' a monoidal value onto the end of the target of a 'Lens' and+-- return the result+--+-- When you do not need the result of the operation, ('<>~') is more flexible.+(<<>~) :: Monoid m => LensLike ((,)m) s t m m -> m -> s -> (m, t)+l <<>~ m = l <%~ (`mappend` m)+{-# INLINE (<<>~) #-}++-- | 'mappend' a monoidal 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, ('<>=') is more flexible.+(<<>=) :: (MonadState s m, Monoid r) => SimpleLensLike ((,)r) s r -> r -> m r+l <<>= r = l <%= (`mappend` r)+{-# INLINE (<<>=) #-}+ -- | Useful for storing lenses in containers. newtype ReifiedLens s t a b = ReifyLens { reflectLens :: Lens s t a b }
src/Control/Lens/WithIndex.hs view
@@ -4,11 +4,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 706+#ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 706 #define MPTC_DEFAULTS #endif+#endif+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-} -- vector, hashable+#endif + #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif@@ -67,7 +73,6 @@ import Control.Lens.Fold import Control.Lens.Internal import Control.Lens.Internal.Combinators-import Control.Lens.Indexed import Control.Lens.IndexedSetter import Control.Lens.IndexedFold import Control.Lens.IndexedTraversal@@ -103,6 +108,7 @@ #ifdef MPTC_DEFAULTS default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b imap = imapOf itraversed+ {-# INLINE imap #-} #endif -- | The 'IndexedSetter' for a 'FunctorWithIndex'.@@ -143,9 +149,9 @@ -- | -- Left-associative fold of an indexed container with access to the index @i@. --- -- When you don't need access to the index then 'foldl' is more flexible in what it accepts.+ -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts. --- -- @'foldl' ≡ 'ifoldl' '.' 'const'@+ -- @'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const'@ ifoldl :: (i -> b -> a -> b) -> b -> f a -> b ifoldl f z t = appEndo (getDual (ifoldMap (\i -> dual# (endo# (flip (f i)))) t)) z @@ -163,27 +169,20 @@ -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts. -- -- @'Control.Lens.Fold.foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const'@- --- -- @- -- 'ifoldlOf'' :: 'Control.Lens.IndexedGetter.IndexedGetter' i a c -> (i -> e -> c -> e) -> e -> a -> e- -- 'ifoldlOf'' :: 'IndexedFold' i a c -> (i -> e -> c -> e) -> e -> a -> e- -- 'ifoldlOf'' :: 'Control.Lens.IndexedLens.SimpleIndexedLens' i a c -> (i -> e -> c -> e) -> e -> a -> e- -- 'ifoldlOf'' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i a c -> (i -> e -> c -> e) -> e -> a -> e- -- @ ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b ifoldl' f z0 xs = ifoldr f' id xs z0 where f' i x k z = k $! f i z x -- | The 'IndexedFold' of a 'FoldableWithIndex' container. ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a-ifolded = index $ \ f -> coerce . getFolding . ifoldMap (\i -> folding# (f i))+ifolded = indexed $ \ f -> coerce . getFolding . ifoldMap (\i -> folding# (f i)) {-# INLINE ifolded #-} -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'.-ifolding :: FoldableWithIndex i f => (a -> f c) -> IndexedFold i a c-ifolding afc = index $ \ icgd -> coerce . itraverse_ icgd . afc+ifolding :: FoldableWithIndex i f => (s -> f a) -> IndexedFold i s a+ifolding sfa = indexed $ \ iagb -> coerce . itraverse_ iagb . sfa {-# INLINE ifolding #-} -- |@@ -191,7 +190,7 @@ -- -- When you don't need access to the index then 'any' is more flexible in what it accepts. ----- @'any' = 'iany' '.' 'const'@+-- @'any' ≡ 'iany' '.' 'const'@ iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool iany f = getAny# (ifoldMap (\i -> any# (f i))) {-# INLINE iany #-}@@ -300,9 +299,9 @@ -- | Extract the key-value pairs from a structure. ----- When you don't need access to the indices in the result, then 'toList' is more flexible in what it accepts.+-- When you don't need access to the indices in the result, then 'Data.Foldable.toList' is more flexible in what it accepts. ----- @'toList' ≡ 'map' 'fst' '.' 'itoList'@+-- @'Data.Foldable.toList' ≡ 'Data.List.map' 'fst' '.' 'itoList'@ itoList :: FoldableWithIndex i f => f a -> [(i,a)] itoList = ifoldr (\i c -> ((i,c):)) [] {-# INLINE itoList #-}@@ -338,13 +337,13 @@ itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b) #ifdef MPTC_DEFAULTS default itraverse :: Applicative f => (Int -> a -> f b) -> t a -> f (t b)- itraverse = withIndex (indexed traverse)+ itraverse = withIndex traversed {-# INLINE itraverse #-} #endif -- | The 'IndexedTraversal' of a 'TraversableWithIndex' container. itraversed :: TraversableWithIndex i f => IndexedTraversal i (f a) (f b) a b-itraversed = index itraverse+itraversed = indexed itraverse {-# INLINE itraversed #-} -- |@@ -404,7 +403,7 @@ -- >>> over (iwhere (>0)) Prelude.reverse $ ["He","was","stressed","o_O"] -- ["He","saw","desserts","O_o"] iwhere :: TraversableWithIndex i t => (i -> Bool) -> SimpleIndexedTraversal i (t a) a-iwhere p = index $ \f a -> itraverse (\i c -> if p i then f i c else pure c) a+iwhere p = indexed $ \f a -> itraverse (\i c -> if p i then f i c else pure c) a {-# INLINE iwhere #-} -------------------------------------------------------------------------------@@ -414,34 +413,45 @@ -- | The position in the list is available as the index. instance FunctorWithIndex Int [] where imap = imapOf itraversed+ {-# INLINE imap #-} instance FoldableWithIndex Int [] where ifoldMap = ifoldMapOf itraversed+ {-# INLINE ifoldMap #-} instance TraversableWithIndex Int [] where- itraverse = withIndex (indexed traverse)+ itraverse = withIndex traversed+ {-# INLINE itraverse #-} -- | The position in the sequence is available as the index. instance FunctorWithIndex Int Seq where imap = imapOf itraversed+ {-# INLINE imap #-} instance FoldableWithIndex Int Seq where ifoldMap = ifoldMapOf itraversed+ {-# INLINE ifoldMap #-} instance TraversableWithIndex Int Seq where- itraverse = withIndex (indexed traverse)+ itraverse = withIndex traversed+ {-# INLINE itraverse #-} instance FunctorWithIndex Int Vector where imap = V.imap+ {-# INLINE imap #-} instance FoldableWithIndex Int Vector where ifoldMap = ifoldMapOf itraversed+ {-# INLINE ifoldMap #-} ifoldr = V.ifoldr ifoldl = V.ifoldl . flip ifoldr' = V.ifoldr' ifoldl' = V.ifoldl' . flip instance TraversableWithIndex Int Vector where itraverse f = sequenceA . V.imap f+ {-# INLINE itraverse #-} instance FunctorWithIndex Int IntMap where imap = imapOf itraversed+ {-# INLINE imap #-} instance FoldableWithIndex Int IntMap where ifoldMap = ifoldMapOf itraversed+ {-# INLINE ifoldMap #-} instance TraversableWithIndex Int IntMap where #if MIN_VERSION_containers(0,5,0) itraverse = IntMap.traverseWithKey@@ -450,11 +460,13 @@ #endif {-# INLINE itraverse #-} -instance Ord k => FunctorWithIndex k (Map k) where+instance FunctorWithIndex k (Map k) where imap = imapOf itraversed-instance Ord k => FoldableWithIndex k (Map k) where+ {-# INLINE imap #-}+instance FoldableWithIndex k (Map k) where ifoldMap = ifoldMapOf itraversed-instance Ord k => TraversableWithIndex k (Map k) where+ {-# INLINE ifoldMap #-}+instance TraversableWithIndex k (Map k) where #if MIN_VERSION_containers(0,5,0) itraverse = Map.traverseWithKey #else@@ -464,8 +476,10 @@ instance (Eq k, Hashable k) => FunctorWithIndex k (HashMap k) where imap = imapOf itraversed+ {-# INLINE imap #-} instance (Eq k, Hashable k) => FoldableWithIndex k (HashMap k) where ifoldMap = ifoldMapOf itraversed+ {-# INLINE ifoldMap #-} instance (Eq k, Hashable k) => TraversableWithIndex k (HashMap k) where itraverse = HashMap.traverseWithKey {-# INLINE itraverse #-}
+ src/Control/Lens/Wrapped.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Wrapped+-- Copyright : (C) 2012 Edward Kmett, Michael Sloan+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : Rank2, MPTCs, fundeps+--+-- The 'Wrapped' class provides similar functionality as @Control.Newtype@,+-- from the @newtype@ package, but in a more convenient and efficient form.+--+-- There are a few functions from @newtype@ that are not provided here, because+-- they can be done with the 'Iso' directly:+--+-- @+-- Control.Newtype.over 'Sum' f ≡ 'wrapping' 'Sum' '%~' f+-- Control.Newtype.under 'Sum' f ≡ 'unwrapping' 'Sum' '%~' f+-- Control.Newtype.overF 'Sum' f ≡ 'mapping' ('wrapping' 'Sum') '%~' f+-- Control.Newtype.underF 'Sum' f ≡ 'mapping' ('unwrapping' 'Sum') '%~' f+-- @+--+-- 'under' can also be used with 'wrapping' to provide the equivalent of+-- @Control.Newtype.under@. Also, most use cases don't need full polymorphism,+-- so only the single constructor 'wrapping' functions would be needed.+--+-- These equivalences aren't 100% honest, because @newtype@'s operators+-- need to rely on two @Newtype@ constraints. This means that the wrapper used+-- for the output is not necessarily the same as the input.+--+----------------------------------------------------------------------------+module Control.Lens.Wrapped+ ( Wrapped(..)+ , wrapping, unwrapping+ , wrappings, unwrappings+ , op+ , ala, alaf+ ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Arrow+-- import Control.Comonad.Trans.Env+-- import Control.Comonad.Trans.Store+import Control.Comonad.Trans.Traced+import Control.Exception+import Control.Lens.Prism+import Control.Lens.Iso+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict+import Data.Foldable as Foldable+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Coproduct+import Data.Functor.Identity+import Data.Functor.Reverse+import Data.Hashable+import Data.IntSet as IntSet+import Data.IntMap as IntMap+import Data.HashSet as HashSet+import Data.HashMap.Lazy as HashMap+import Data.Map as Map+import Data.Monoid+import Data.Sequence as Seq hiding (length)+import Data.Set as Set++-- $setup+-- >>> import Control.Lens+-- >>> import Data.Foldable++-- | 'Wrapped' provides isomorphisms to wrap and unwrap newtypes or+-- data types with one constructor.+class Wrapped s t a b | a -> s, b -> t, a t -> s, b s -> t where+ -- | An isomorphism between s and @a@ and a related one between @t@ and @b@, such that when @a = b@, @s = t@.+ --+ -- This is often used via 'wrapping' to aid type inference.+ wrapped :: Iso s t a b++-- * base++instance Wrapped Bool Bool All All where+ wrapped = iso All getAll+ {-# INLINE wrapped #-}++instance Wrapped Bool Bool Any Any where+ wrapped = iso Any getAny+ {-# INLINE wrapped #-}++instance Wrapped a b (Sum a) (Sum b) where+ wrapped = iso Sum getSum+ {-# INLINE wrapped #-}++instance Wrapped a b (Product a) (Product b) where+ wrapped = iso Product getProduct+ {-# INLINE wrapped #-}++instance Wrapped (a -> m b) (u -> n v) (Kleisli m a b) (Kleisli n u v) where+ wrapped = iso Kleisli runKleisli+ {-# INLINE wrapped #-}++instance Wrapped (m a) (n b) (WrappedMonad m a) (WrappedMonad n b) where+ wrapped = iso WrapMonad unwrapMonad+ {-# INLINE wrapped #-}++instance Wrapped (a b c) (u v w) (WrappedArrow a b c) (WrappedArrow u v w) where+ wrapped = iso WrapArrow unwrapArrow+ {-# INLINE wrapped #-}++instance Wrapped [a] [b] (ZipList a) (ZipList b) where+ wrapped = iso ZipList getZipList+ {-# INLINE wrapped #-}++instance Wrapped a b (Const a x) (Const b y) where+ wrapped = iso Const getConst+ {-# INLINE wrapped #-}++instance Wrapped (a -> a) (b -> b) (Endo a) (Endo b) where+ wrapped = iso Endo appEndo+ {-# INLINE wrapped #-}++instance Wrapped (Maybe a) (Maybe b) (First a) (First b) where+ wrapped = iso First getFirst+ {-# INLINE wrapped #-}++instance Wrapped (Maybe a) (Maybe b) (Last a) (Last b) where+ wrapped = iso Last getLast+ {-# INLINE wrapped #-}++instance (ArrowApply m, ArrowApply n) => Wrapped (m () a) (n () b) (ArrowMonad m a) (ArrowMonad n b) where+ wrapped = iso ArrowMonad getArrowMonad+ {-# INLINE wrapped #-}++-- * transformers++instance Wrapped (f a) (f' a') (Backwards f a) (Backwards f' a') where+ wrapped = iso Backwards forwards+ {-# INLINE wrapped #-}++instance Wrapped (f (g a)) (f' (g' a')) (Compose f g a) (Compose f' g' a') where+ wrapped = iso Compose getCompose+ {-# INLINE wrapped #-}++instance Wrapped a a' (Constant a b) (Constant a' b') where+ wrapped = iso Constant getConstant+ {-# INLINE wrapped #-}++instance Wrapped ((a -> m r) -> m r) ((a' -> m' r') -> m' r') (ContT r m a) (ContT r' m' a') where+ wrapped = iso ContT runContT+ {-# INLINE wrapped #-}++instance Wrapped (m (Either e a)) (m' (Either e' a')) (ErrorT e m a) (ErrorT e' m' a') where+ wrapped = iso ErrorT runErrorT+ {-# INLINE wrapped #-}++instance Wrapped a a' (Identity a) (Identity a') where+ wrapped = iso Identity runIdentity+ {-# INLINE wrapped #-}++instance Wrapped (m a) (m' a') (IdentityT m a) (IdentityT m' a') where+ wrapped = iso IdentityT runIdentityT+ {-# INLINE wrapped #-}++instance (Applicative f, Applicative g) => Wrapped (f a) (g b) (Lift f a) (Lift g b) where+ wrapped = iso Other unLift+ {-# INLINE wrapped #-}++instance Wrapped (m [a]) (m' [a']) (ListT m a) (ListT m' a') where+ wrapped = iso ListT runListT+ {-# INLINE wrapped #-}++instance Wrapped (m (Maybe a)) (m' (Maybe a')) (MaybeT m a) (MaybeT m' a') where+ wrapped = iso MaybeT runMaybeT+ {-# INLINE wrapped #-}++instance Wrapped (r -> m a) (r' -> m' a') (ReaderT r m a) (ReaderT r' m' a') where+ wrapped = iso ReaderT runReaderT+ {-# INLINE wrapped #-}++instance Wrapped (f a) (f' a') (Reverse f a) (Reverse f' a') where+ wrapped = iso Reverse getReverse+ {-# INLINE wrapped #-}++instance Wrapped (r -> s -> m (a, s, w)) (r' -> s' -> m' (a', s', w')) (Lazy.RWST r w s m a) (Lazy.RWST r' w' s' m' a') where+ wrapped = iso Lazy.RWST Lazy.runRWST+ {-# INLINE wrapped #-}++instance Wrapped (r -> s -> m (a, s, w)) (r' -> s' -> m' (a', s', w')) (Strict.RWST r w s m a) (Strict.RWST r' w' s' m' a') where+ wrapped = iso Strict.RWST Strict.runRWST+ {-# INLINE wrapped #-}++instance Wrapped (s -> m (a, s)) (s' -> m' (a', s')) (Lazy.StateT s m a) (Lazy.StateT s' m' a') where+ wrapped = iso Lazy.StateT Lazy.runStateT+ {-# INLINE wrapped #-}++instance Wrapped (s -> m (a, s)) (s' -> m' (a', s')) (Strict.StateT s m a) (Strict.StateT s' m' a') where+ wrapped = iso Strict.StateT Strict.runStateT+ {-# INLINE wrapped #-}++instance Wrapped (m (a, w)) (m' (a', w')) (Lazy.WriterT w m a) (Lazy.WriterT w' m' a') where+ wrapped = iso Lazy.WriterT Lazy.runWriterT+ {-# INLINE wrapped #-}++instance Wrapped (m (a, w)) (m' (a', w')) (Strict.WriterT w m a) (Strict.WriterT w' m' a') where+ wrapped = iso Strict.WriterT Strict.runWriterT+ {-# INLINE wrapped #-}++-- * comonad-transformers++instance Wrapped (Either (f a) (g a)) (Either (f' a') (g' a')) (Coproduct f g a) (Coproduct f' g' a') where+ wrapped = iso Coproduct getCoproduct+ {-# INLINE wrapped #-}++instance Wrapped (w (m -> a)) (w' (m' -> a')) (TracedT m w a) (TracedT m' w' a') where+ wrapped = iso TracedT runTracedT+ {-# INLINE wrapped #-}++-- * unordered-containers++-- | Use @'wrapping' HashMap.fromList'@. Unwrapping returns some permutation of the list.+instance (Hashable k, Eq k, Hashable k', Eq k') => Wrapped [(k, a)] [(k', b)] (HashMap k a) (HashMap k' b) where+ wrapped = iso HashMap.fromList HashMap.toList++-- | Use @'wrapping' HashSet.fromList'@. Unwrapping returns some permutation of the list.+instance (Hashable a, Eq a, Hashable b, Eq b) => Wrapped [a] [b] (HashSet a) (HashSet b) where+ wrapped = iso HashSet.fromList HashSet.toList++-- * containers++-- | Use @'wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list.+instance Wrapped [(Int, a)] [(Int, b)] (IntMap a) (IntMap b) where+ wrapped = iso IntMap.fromList IntMap.toAscList++-- | Use @'wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list.+instance Wrapped [Int] [Int] IntSet IntSet where+ wrapped = iso IntSet.fromList IntSet.toAscList++-- | Use @'wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list.+instance (Ord k, Ord k') => Wrapped [(k, a)] [(k', b)] (Map k a) (Map k' b) where+ wrapped = iso Map.fromList Map.toAscList++-- | Use @'wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list.+instance (Ord a, Ord b) => Wrapped [a] [b] (Set a) (Set b) where+ wrapped = iso Set.fromList Set.toAscList++instance Wrapped [a] [b] (Seq a) (Seq b) where+ wrapped = iso Seq.fromList Foldable.toList++-- * Control.Exception++instance Wrapped String String AssertionFailed AssertionFailed where+ wrapped = iso AssertionFailed failedAssertion+ {-# INLINE wrapped #-}++instance Wrapped String String NoMethodError NoMethodError where+ wrapped = iso NoMethodError getNoMethodError+ {-# INLINE wrapped #-}++instance Wrapped String String PatternMatchFail PatternMatchFail where+ wrapped = iso PatternMatchFail getPatternMatchFail+ {-# INLINE wrapped #-}++instance Wrapped String String RecConError RecConError where+ wrapped = iso RecConError getRecConError+ {-# INLINE wrapped #-}++instance Wrapped String String RecSelError RecSelError where+ wrapped = iso RecSelError getRecSelError+ {-# INLINE wrapped #-}++instance Wrapped String String RecUpdError RecUpdError where+ wrapped = iso RecUpdError getRecUpdError+ {-# INLINE wrapped #-}++instance Wrapped String String ErrorCall ErrorCall where+ wrapped = iso ErrorCall getErrorCall+ {-# INLINE wrapped #-}++getErrorCall :: ErrorCall -> String+getErrorCall (ErrorCall x) = x+{-# INLINE getErrorCall #-}++getRecUpdError :: RecUpdError -> String+getRecUpdError (RecUpdError x) = x+{-# INLINE getRecUpdError #-}++getRecSelError :: RecSelError -> String+getRecSelError (RecSelError x) = x+{-# INLINE getRecSelError #-}++getRecConError :: RecConError -> String+getRecConError (RecConError x) = x+{-# INLINE getRecConError #-}++getPatternMatchFail :: PatternMatchFail -> String+getPatternMatchFail (PatternMatchFail x) = x+{-# INLINE getPatternMatchFail #-}++getNoMethodError :: NoMethodError -> String+getNoMethodError (NoMethodError x) = x+{-# INLINE getNoMethodError #-}++failedAssertion :: AssertionFailed -> String+failedAssertion (AssertionFailed x) = x+{-# INLINE failedAssertion #-}++getArrowMonad :: ArrowApply m => ArrowMonad m a -> m () a+getArrowMonad (ArrowMonad x) = x+{-# INLINE getArrowMonad #-}++-- | Given the constructor for a @Wrapped@ type, return a+-- deconstructor that is its inverse.+--+-- Assuming the @Wrapped@ instance is legal, these laws hold:+--+-- @+-- 'op' f '.' f ≡ 'id'+-- f '.' 'op' f ≡ 'id'+-- @+--+--+-- >>> op Identity (Identity 4)+-- 4+--+-- >>> op Const (Const "hello")+-- "hello"+op :: Wrapped s s a a => (s -> a) -> a -> s+op f = review (wrapping f)+{-# INLINE op #-}++-- | This is a convenient alias for @'from' 'wrapped'@+--+-- >>> Const "hello" & unwrapped %~ length & getConst+-- 5+unwrapped :: Wrapped t s b a => Iso a b s t+unwrapped = from wrapped+{-# INLINE unwrapped #-}++-- | This is a convenient version of 'wrapped' with an argument that's ignored.+--+-- The argument is used to specify which newtype the user intends to wrap+-- by using the constructor for that newtype.+--+-- The user supplied function is /ignored/, merely its type is used.+wrapping :: Wrapped s s a a => (s -> a) -> Iso s s a a+wrapping _ = wrapped+{-# INLINE wrapping #-}++-- | This is a convenient version of 'unwrapped' with an argument that's ignored.+--+-- The argument is used to specify which newtype the user intends to /remove/+-- by using the constructor for that newtype.+--+-- The user supplied function is /ignored/, merely its type is used.+unwrapping :: Wrapped s s a a => (s -> a) -> Iso a a s s+unwrapping _ = unwrapped+{-# INLINE unwrapping #-}++-- | This is a convenient version of 'wrapped' with two arguments that are ignored.+--+-- These arguments are used to which newtype the user intends to wrap and+-- should both be the same constructor. This redundancy is necessary+-- in order to find the full polymorphic isomorphism family.+--+-- The user supplied functions are /ignored/, merely their types are used.+wrappings :: Wrapped s t a b => (s -> a) -> (t -> b) -> Iso s t a b+wrappings _ _ = wrapped+{-# INLINE wrappings #-}++-- | This is a convenient version of 'unwrapped' with two arguments that are ignored.+--+-- These arguments are used to which newtype the user intends to remove and+-- should both be the same constructor. This redundancy is necessary+-- in order to find the full polymorphic isomorphism family.+--+-- The user supplied functions are /ignored/, merely their types are used.+unwrappings :: Wrapped t s b a => (s -> a) -> (t -> b) -> Iso a b s t+unwrappings _ _ = unwrapped+{-# INLINE unwrappings #-}++-- | This combinator is based on @ala@ from Conor McBride's work on Epigram.+--+-- As with 'wrapping', the user supplied function for the newtype is /ignored/.+--+-- >>> ala Sum foldMap [1,2,3,4]+-- 10+--+-- >>> ala All foldMap [True,True]+-- True+--+-- >>> ala All foldMap [True,False]+-- False+--+-- >>> ala Any foldMap [False,False]+-- False+--+-- >>> ala Any foldMap [True,False]+-- True+--+-- >>> ala Sum foldMap [1,2,3,4]+-- 10+--+-- >>> ala Product foldMap [1,2,3,4]+-- 24+ala :: Wrapped s s a a => (s -> a) -> ((s -> a) -> e -> a) -> e -> s+ala = au . wrapping+{-# INLINE ala #-}++-- |+-- This combinator is based on @ala'@ from Conor McBride's work on Epigram.+--+-- As with 'wrapping', the user supplied function for the newtype is /ignored/.+--+-- >>> alaf Sum foldMap length ["hello","world"]+-- 10+alaf :: Wrapped s s a a => (s -> a) -> ((r -> a) -> e -> a) -> (r -> s) -> e -> s+alaf = auf . wrapping+{-# INLINE alaf #-}
src/Control/Lens/Zipper.hs view
@@ -17,17 +17,17 @@ -- -- [@'Top' ':>' a@] represents a trivial 'Zipper' with its focus at the root. ----- [@'Top' ':>' 'Data.Tree.Tree' a ':>' a@] represents a zipper that starts with a+-- [@'Top' ':>' 'Data.Tree.Tree' a ':>' a@] represents a 'Zipper' that starts with a -- 'Data.Tree.Tree' and descends in a single step to values of type @a@. -- -- [@'Top' ':>' 'Data.Tree.Tree' a ':>' 'Data.Tree.Tree' a ':>' 'Data.Tree.Tree' a@] represents a 'Zipper' into a -- 'Data.Tree.Tree' with an intermediate bookmarked 'Data.Tree.Tree', -- focusing in yet another 'Data.Tree.Tree'. ----- Since individual levels of a zipper are managed by an arbitrary 'Traversal',+-- Since individual levels of a 'Zipper' are managed by an arbitrary 'Traversal', -- you can move left and right through the 'Traversal' selecting neighboring elements. ----- >>> zipper ("hello","world") & down _1 & fromWithin traverse & focus .~ 'J' & farthest right & focus .~ 'y' & rezip+-- >>> zipper ("hello","world") & downward _1 & fromWithin traverse & focus .~ 'J' & rightmost & focus .~ 'y' & rezip -- ("Jelly","world") -- -- This is particularly powerful when compiled with 'Control.Lens.Plated.plate',@@ -39,16 +39,21 @@ -- * Zippers Top() , (:>)()+ , Zipper , zipper -- ** Focusing , focus- -- ** Horizontal Movement- , up- , down+ , focusedContext+ -- ** Vertical Movement+ , upward+ , downward , within+ , withins -- ** Lateral Movement- , left- , right+ , leftward+ , rightward+ , leftmost+ , rightmost -- ** Movement Combinators , tug , tugs@@ -62,7 +67,7 @@ -- ** Closing the zipper , rezip , Zipped- , Zipper()+ , Zipping() -- ** Recording , Tape() , saveTape
src/Control/Lens/Zoom.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -31,13 +31,13 @@ import Control.Lens.Internal.Combinators import Control.Lens.Type import Control.Monad-import Control.Monad.Reader.Class as Reader-import Control.Monad.State.Class as State-import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Reader.Class as Reader+import Control.Monad.State as State+import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict-import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict-import Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Error@@ -46,6 +46,19 @@ import Control.Monad.Trans.Maybe import Data.Monoid +-- $setup+-- >>> import Control.Lens+-- >>> import Control.Monad.State+-- >>> import Data.Map as Map+-- >>> import Debug.SimpleReflect.Expr as Expr+-- >>> import Debug.SimpleReflect.Vars as Vars+-- >>> let f :: Expr -> Expr; f = Vars.f+-- >>> let g :: Expr -> Expr; g = Vars.g+-- >>> let h :: Expr -> Expr -> Expr; h = Vars.h++-- Chosen so that they have lower fixity than ('%='), and to match ('<~')+infixr 2 `zoom`, `magnify`+ -- | This class allows us to use 'zoom' in, changing the State supplied by -- many different monad transformers, potentially quite deep in a monad transformer stack. class (MonadState s m, MonadState t n) => Zoom m n k s t | m -> s k, n -> t k, m t -> n, n s -> m where@@ -61,6 +74,21 @@ -- -- This can be used to edit pretty much any monad transformer stack with a state in it! --+ -- >>> flip State.evalState (a,b) $ zoom _1 $ use id+ -- a+ --+ -- >>> flip State.execState (a,b) $ zoom _1 $ id .= c+ -- (c,b)+ --+ -- >>> flip State.execState [(a,b),(c,d)] $ zoom traverse $ _2 %= f+ -- [(a,f b),(c,f d)]+ --+ -- >>> flip State.runState [(a,b),(c,d)] $ zoom traverse $ _2 <%= f+ -- (f b <> f d <> mempty,[(a,f b),(c,f d)])+ --+ -- >>> flip State.evalState (a,b) $ zoom both (use id)+ -- a <> b+ -- -- @ -- 'zoom' :: 'Monad' m => 'Simple' 'Lens' s t -> 'StateT' t m a -> 'StateT' s m a -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Simple' 'Control.Lens.Traversal.Traversal' s t -> 'StateT' t m c -> 'StateT' s m c@@ -70,7 +98,7 @@ -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Simple' 'Control.Lens.Traversal.Traversal' s t -> 'ErrorT' e ('RWST' r w t m c) -> 'ErrorT' e ('RWST' r w s m c) -- ... -- @- zoom :: Monad m => SimpleLensLike (k c) t s -> m c -> n c+ zoom :: SimpleLensLike (k c) t s -> m c -> n c instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) (Focusing z) s t where zoom l (Strict.StateT m) = Strict.StateT $ unfocusing# (l (focusing# m))
src/Control/Parallel/Strategies/Lens.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
src/Data/Array/Lens.hs view
@@ -37,7 +37,7 @@ -- >>> ix 2 .~ 9 $ (listArray (1,5) [4,5,6,7,8] :: Array Int Int) -- array (1,5) [(1,4),(2,9),(3,6),(4,7),(5,8)] ix :: (IArray a e, Ix i) => i -> Simple Lens (a i e) e-ix i f arr = (\e -> arr // [(i,e)]) <$> f (arr ! i)+ix i f arr = f (arr ! i) <&> \e -> arr // [(i,e)] {-# INLINE ix #-} -- | This setter can be used to derive a new 'IArray' from an old array by@@ -60,5 +60,5 @@ -- -- @'amap' ≡ 'over' '_array'@ _array :: (IArray arr a, IArray arr b, Ix i) => IndexedTraversal i (arr i a) (arr i b) a b-_array = index $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr)+_array = indexed $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr) {-# INLINE _array #-}
src/Data/Bits/Lens.hs view
@@ -163,7 +163,7 @@ -- >>> 16 & bitAt 4 .~ False -- 0 bitAt :: Bits b => Int -> SimpleIndexedLens Int b Bool-bitAt n = index $ \f b -> (\x -> if x then setBit b n else clearBit b n) <$> f n (testBit b n)+bitAt n = indexed $ \f b -> f n (testBit b n) <&> \x -> if x then setBit b n else clearBit b n {-# INLINE bitAt #-} -- | Traverse over all bits in a numeric type.@@ -176,7 +176,7 @@ -- If you supply this an 'Integer', the result will be an infinite 'Traversal', which -- can be productively consumed, but not reassembled. bits :: (Num b, Bits b) => SimpleIndexedTraversal Int b Bool-bits = index $ \f b -> let+bits = indexed $ \f b -> let g n = (,) n <$> f n (testBit b n) bs = Prelude.takeWhile hasBit [0..] hasBit n = complementBit b n /= b -- test to make sure that complementing this bit actually changes the value
src/Data/ByteString/Lazy/Lens.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- |@@ -5,8 +6,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- -- Lenses for lazy bytestrings ----------------------------------------------------------------------------
src/Data/ByteString/Lens.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- |@@ -5,8 +6,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Lens
src/Data/ByteString/Strict/Lens.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- |@@ -5,8 +6,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Strict.Lens
src/Data/Complex/Lens.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif@@ -9,15 +11,18 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental--- Portability : Rank2Types+-- Portability : non-portable -- -- Lenses and traversals for complex numbers -- ---------------------------------------------------------------------------- module Data.Complex.Lens- ( real- , imaginary- , polarize+ ( _realPart+ , _imagPart+ , _polar+ , _magnitude+ , _phase+ , _conjugate , complex ) where @@ -25,56 +30,114 @@ import Control.Lens import Data.Complex +-- $setup+-- >>> import Debug.SimpleReflect+-- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ }+ -- | Access the 'realPart' of a 'Complex' number ----- >>> (1.0 :+ 0.0)^.real--- 1.0+-- >>> (a :+ b)^._realPart+-- a ----- >>> 3 :+ 1 & real *~ 2--- 6 :+ 1+-- >>> a :+ b & _realPart *~ 2+-- a * 2 :+ b ----- @'real' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@+-- @'_realPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0)-real :: Simple Lens (Complex a) a+_realPart :: Simple Lens (Complex a) a #else-real :: RealFloat a => Simple Lens (Complex a) a+_realPart :: RealFloat a => Simple Lens (Complex a) a #endif-real f (a :+ b) = (:+ b) <$> f a+_realPart f (a :+ b) = (:+ b) <$> f a --- | Access the 'imaginaryPart' of a 'Complex' number+-- | Access the 'imagPart' of a 'Complex' number ----- >>> (0.0 :+ 1.0)^.imaginary--- 1.0+-- >>> (a :+ b)^._imagPart+-- b ----- @'imaginary' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@+-- >>> a :+ b & _imagPart *~ 2+-- a :+ b * 2+--+-- @'_imagPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0)-imaginary :: Simple Lens (Complex a) a+_imagPart :: Simple Lens (Complex a) a #else-imaginary :: RealFloat a => Simple Lens (Complex a) a+_imagPart :: RealFloat a => Simple Lens (Complex a) a #endif-imaginary f (a :+ b) = (a :+) <$> f b+_imagPart f (a :+ b) = (a :+) <$> f b --- | This isn't /quite/ a legal lens. Notably the +-- | This isn't /quite/ a legal lens. Notably the -- -- @'view' l ('set' l b a) = b@ ----- law is violated when you set a 'polar' value with 0 'magnitude' and non-zero 'phase'--- as the 'phase' information is lost. So don't do that!+-- law is violated when you set a 'polar' value with 0 'magnitude' and non-zero+-- 'phase' as the 'phase' information is lost, or with a negative 'magnitude'+-- which flips the 'phase' and retains a positive 'magnitude'. So don't do+-- that! -- -- Otherwise, this is a perfectly cromulent 'Lens'.-polarize :: RealFloat a => Simple Iso (Complex a) (a,a)-polarize = iso polar (uncurry mkPolar)+_polar :: RealFloat a => Simple Iso (Complex a) (a,a)+_polar = iso polar (uncurry mkPolar) --- | Traverse both the 'real' and 'imaginary' parts of a 'Complex' number.+-- | Access the 'magnitude' of a 'Complex' number ----- >>> 0 & complex .~ 1--- 1 :+ 1+-- >>> (10.0 :+ 20.0) & _magnitude *~ 2+-- 20.0 :+ 40.0 ----- >>> 3 :+ 4 & complex *~ 2--- 6 :+ 8+-- This isn't /quite/ a legal lens. Notably the ----- >>> sumOf complex (1 :+ 2)--- 3+-- @'view' l ('set' l b a) = b@+--+-- law is violated when you set a negative 'magnitude'. This flips the 'phase'+-- and retains a positive 'magnitude'. So don't do that!+--+-- Otherwise, this is a perfectly cromulent 'Lens'.+--+-- Setting the 'magnitude' of a zero 'Complex' number assumes the 'phase' is 0.+_magnitude :: RealFloat a => Simple Lens (Complex a) a+_magnitude f c = setMag <$> f r+ where setMag r' | r /= 0 = c * (r' / r :+ 0)+ | otherwise = r' :+ 0+ r = magnitude c++-- | Access the 'phase' of a 'Complex' number+--+-- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2+-- True+--+-- This isn't /quite/ a legal lens. Notably the+--+-- @'view' l ('set' l b a) = b@+--+-- law is violated when you set a 'phase' outside the range @(-'pi', 'pi']@.+-- The phase is always in that range when queried. So don't do that!+--+-- Otherwise, this is a perfectly cromulent 'Lens'.+_phase :: RealFloat a => Simple Lens (Complex a) a+_phase f c = setPhase <$> f theta+ where setPhase theta' = c * cis (theta' - theta)+ theta = phase c++-- | Access the 'conjugate' of a 'Complex' number+--+-- >>> (2.0 :+ 3.0) & _conjugate . _imagPart -~ 1+-- 2.0 :+ 4.0+--+-- >>> (mkPolar 10.0 2.0 ^. _conjugate . _phase) ≈ (-2.0)+-- True+_conjugate :: RealFloat a => Simple Iso (Complex a) (Complex a)+_conjugate = iso conjugate conjugate++-- | Traverse both the 'realPart' and the 'imagPart' of a 'Complex' number.+--+-- >>> a :+ b & complex .~ c+-- c :+ c+--+-- >>> a :+ b & complex *~ 2+-- a * 2 :+ b * 2+--+-- >>> sumOf complex (a :+ b)+-- a + b -- -- @'complex' :: 'Applicative' f => (a -> f b) -> 'Complex' a -> f ('Complex' b)@ #if MIN_VERSION_base(4,4,0)
src/Data/Data/Lens.hs view
@@ -9,7 +9,7 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -37,14 +37,13 @@ -- * Field Accessor Traversal , upon , upon'- , uponTheDeep- , uponTheDeep'+ , onceUpon+ , onceUpon' -- * Data Traversal , gtraverse ) where import Control.Applicative-import Control.Arrow ((&&&)) import Control.Exception as E import Control.Lens.Getter import Control.Lens.Indexed@@ -56,6 +55,11 @@ import Control.Lens.Traversal import Control.Lens.Type import Data.Data+import GHC.IO+import Unsafe.Coerce as Unsafe++#ifndef SAFE+import Control.Arrow ((&&&)) import Data.Foldable import qualified Data.HashMap.Strict as M import Data.HashMap.Strict (HashMap, (!))@@ -63,9 +67,8 @@ import Data.HashSet (HashSet) import Data.IORef import Data.Monoid-import GHC.IO import GHC.Exts (realWorld#)-import Unsafe.Coerce as Unsafe+#endif -- $setup -- >>> import Control.Lens@@ -103,14 +106,18 @@ -- Smart Traversal ------------------------------------------------------------------------------- --- | Find every occurence of a given type @a@ recursively that doesn't require+-- | Find every occurrence of a given type @a@ recursively that doesn't require -- passing through something of type @a@ using 'Data', while avoiding traversal -- of areas that cannot contain a value of type @a@. -- -- This is 'uniplate' with a more liberal signature. template :: forall s a. (Data s, Typeable a) => Simple Traversal s a+#ifdef SAFE+template = tinplate+#else template = uniplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a)+#endif {-# INLINE template #-} -- | Find descendants of type @a@ non-transitively, while avoiding computation of areas that cannot contain values of@@ -123,8 +130,14 @@ -- | 'biplate' performs like 'template', except when @s ~ a@, it returns itself and nothing else. biplate :: forall s a. (Data s, Typeable a) => Simple Traversal s a+#ifdef SAFE+biplate f s+ | typeOf (undefined :: s) == typeOf (undefined :: a) = pure s+ | otherwise = template f s+#else biplate = biplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a)+#endif {-# INLINE biplate #-} ------------------------------------------------------------------------------@@ -140,27 +153,25 @@ instance Typeable a => Exception (FieldException a) lookupon :: Typeable a => SimpleLensLike (Indexing Mutator) s a -> (s -> a) -> s -> Maybe (Int, Context a a s)-lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexed l %@~ \i (a::a) -> E.throw (FieldException i a) of+lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexing l %@~ \i (a::a) -> E.throw (FieldException i a) of Right _ -> Nothing Left e -> case fromException e of Nothing -> Nothing Just (FieldException i a) -> Just (i, Context (\a' -> set (elementOf l i) a' s) a) {-# INLINE lookupon #-} --- | This automatically constructs a 'Simple' 'Traversal' from a field accessor.++-- | This automatically constructs a 'Simple' 'Traversal' from an function. -- -- >>> (2,4) & upon fst *~ 5 -- (10,4) ----- There are however, a few caveats on how this function can be used:------ First, the user supplied function must access one of the \"immediate descendants\" of the structure as attempts--- to access deeper structures or use non-field accessor functions will generate an empty 'Traversal'.+-- There are however, caveats on how this function can be used! ----- A more rigorous way to say \"immediate descendants\" is that the function must only inspect one value that would--- be visited by 'template'.+-- First, the user supplied function must access only one field of the specified type. That is to say the target+-- must be a single element that would be visited by @'holesOnOf' 'template' 'uniplate'@ ----- Note: this even permits some functions to be used directly.+-- Note: this even permits a number of functions to be used directly. -- -- >>> [1,2,3,4] & upon head .~ 0 -- [0,2,3,4]@@ -174,30 +185,67 @@ -- >>> "" ^? upon tail -- Nothing ----- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data'+-- Accessing parents on the way down to children is okay: ----- If the supplied function is not a descendant that would be visible to 'template', the resulting 'Traversal'--- will traverse no elements.+-- >>> [1,2,3,4] & upon (tail.tail) .~ [10,20]+-- [1,2,10,20] ----- If the field you name isn't visible to 'template', but is a "descendant" of a field visible to 'template', then--- upon will return the *ancestor* it can visit, not the field you asked for! Be careful.+-- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data' ----- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD--- [1,10,20]+-- @'upon' :: ('Data' s, 'Data' a) => (s -> a) -> 'SimpleIndexedTraversal' [Int] s a@+upon :: forall k f s a. (Indexable [Int] k, Applicative f, Data s, Data a) => (s -> a) -> k (a -> f a) (s -> f s)+upon field = indexed $ \ f s -> case lookupon template field s of+ Nothing -> pure s+ Just (i, Context k0 a0) ->+ let+ go :: [Int] -> SimpleTraversal s a -> (a -> s) -> a -> f s+ go is l k a = case lookupon (l.uniplate) field s of+ Nothing -> k <$> f (reverse is) a+ Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a'+ in go [i] (elementOf template i) k0 a0+{-# INLINE upon #-}++-- | The design of 'onceUpon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.+-- 'upon'' provides this additional recursion. ----- To resolve this when you need deep self-similar recursion, use 'uponTheDeep'. However, 'upon' terminates for--- more inputs, while 'uponTheDeep' can get lost in structures that are infinitely depth-recursive through @a@.+-- Like 'onceUpon'', 'upon'' trusts the user supplied function more than 'upon' using it directly+-- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of+-- generating an illegal lens. ----- >>> uponTheDeep (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD+-- >>> upon' (tail.tail) .~ [10,20] $ [1,2,3,4] -- [1,2,10,20]+upon' :: forall s a. (Data s, Data a) => (s -> a) -> SimpleIndexedLens [Int] s a+upon' field = indexed $ \ f s -> let+ ~(isn, kn) = case lookupon template field s of+ Nothing -> (error "upon': no index, not a member", const s)+ Just (i, Context k0 _) -> go [i] (elementOf template i) k0+ go :: [Int] -> SimpleTraversal s a -> (a -> s) -> ([Int], a -> s)+ go is l k = case lookupon (l.uniplate) field s of+ Nothing -> (reverse is, k)+ Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k'+ in kn <$> f isn (field s)+{-# INLINE upon' #-}++-- | This automatically constructs a 'Simple' 'Traversal' from a field accessor. ----- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexed' 'template')@ or into the list+-- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexing' 'template')@ or into the list -- returned by @'holesOf' 'template'@.-upon :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedTraversal Int s a-upon field = index $ \f s -> case lookupon template field s of+--+-- The design of 'onceUpon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.+-- 'upon' provides this additional recursion, but at the expense of performance.+--+-- >>> onceUpon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD+-- [1,10,20]+--+-- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD+-- [1,2,10,20]+--+-- When in doubt, use 'upon' instead.+onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedTraversal Int s a+onceUpon field = indexed $ \f s -> case lookupon template field s of Nothing -> pure s Just (i, Context k a) -> k <$> f i a-{-# INLINE upon #-}+{-# INLINE onceUpon #-} -- | This more trusting version of 'upon' uses your function directly as the getter for a 'Lens'. --@@ -206,59 +254,23 @@ -- However, you pay for faster access in two ways: -- -- 1. When passed an illegal field accessor, 'upon'' will give you a 'Lens' that quietly violates--- the laws unlike 'upon' will will give you a legal 'Traversal', that avoids modifying the target.+-- the laws, unlike 'upon', which will give you a legal 'Traversal' that avoids modifying the target. -- -- 2. Modifying with the lens is slightly slower, since it has to go back and calculate the index after the fact. -- -- When given a legal field accessor, the index of the 'Lens' can be used as an offset into -- @'elementOf' ('indexed' 'template')@ or into the list returned by @'holesOf' 'template'@.-upon' :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedLens Int s a-upon' field = index $ \f s -> let+--+-- When in doubt, use 'upon'' instead.+onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedLens Int s a+onceUpon' field = indexed $ \f s -> let ~(i, Context k _) = case lookupon template field s of Nothing -> error "upon': no index, not a member" Just ip -> ip in k <$> f i (field s)-{-# INLINE upon' #-}---- | The design of 'upon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.--- uponTheDeep provides this additional recursion. ------ >>> uponTheDeep (tail.tail) .~ [10,20] $ [1,2,3,4]--- [1,2,10,20]------ @'uponTheDeep' :: ('Data' s, 'Data' a) => (s -> a) -> 'SimpleIndexedTraversal' [Int] s a@-uponTheDeep :: forall k f s a. (Indexed [Int] k, Applicative f, Data s, Data a) => (s -> a) -> k (a -> f a) (s -> f s)-uponTheDeep field = index $ \ f s -> case lookupon template field s of- Nothing -> pure s- Just (i, Context k0 a0) ->- let- go :: [Int] -> SimpleTraversal s a -> (a -> s) -> a -> f s- go is l k a = case lookupon (l.uniplate) field s of- Nothing -> k <$> f (reverse is) a- Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a'- in go [i] (elementOf template i) k0 a0-{-# INLINE uponTheDeep #-}+{-# INLINE onceUpon' #-} --- | The design of 'upon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'.--- 'uponTheDeep'' provides this additional recursion.------ Like 'upon'', 'uponTheDeep'' trusts the user supplied function more than 'uponTheDeep' using it directly--- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of--- generating an illegal lens.------ >>> uponTheDeep' (tail.tail) .~ [10,20] $ [1,2,3,4]--- [1,2,10,20]-uponTheDeep' :: forall s a. (Data s, Data a) => (s -> a) -> SimpleIndexedLens [Int] s a-uponTheDeep' field = index $ \ f s -> let- ~(isn, kn) = case lookupon template field s of- Nothing -> (error "uponTheDeep': no index, not a member", const s)- Just (i, Context k0 _) -> go [i] (elementOf template i) k0- go :: [Int] -> SimpleTraversal s a -> (a -> s) -> ([Int], a -> s)- go is l k = case lookupon (l.uniplate) field s of- Nothing -> (reverse is, k)- Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k'- in kn <$> f isn (field s)-{-# INLINE uponTheDeep' #-}+#ifndef SAFE ------------------------------------------------------------------------------- -- Data Box@@ -437,3 +449,4 @@ | otherwise = \k -> not (S.member k miss) where (hit, miss) = part (\x -> S.member b (m ! x)) (S.insert a (m ! a)) +#endif
src/Data/Dynamic/Lens.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- |@@ -19,9 +20,6 @@ -- | -- Traverse the typed value contained in a 'Dynamic' where the type required by your function matches that -- of the contents of the 'Dynamic'.------ >>> ()^.by dynamic--- <<()>>-dynamic :: (Typeable a, Typeable b) => Projection Dynamic Dynamic a b-dynamic = projection toDyn fromDynamic+dynamic :: Typeable a => Simple Prism Dynamic a+dynamic = prism toDyn $ \e -> maybe (Left e) Right (fromDynamic e) {-# INLINE dynamic #-}
src/Data/HashSet/Lens.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
src/Data/List/Lens.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- |@@ -16,19 +15,37 @@ ---------------------------------------------------------------------------- module Data.List.Lens (- -- * Partial Lenses _head , _tail , _last , _init+ , strippingPrefix ) where import Control.Applicative import Control.Lens+import Data.List +-- $setup+-- >>> import Debug.SimpleReflect.Expr+-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- | A 'Traversal' reading and writing to the 'head' of a /non-empty/ list. --+-- >>> [a,b,c]^? _head+-- Just a+--+-- >>> [a,b,c] & _head .~ d+-- [d,b,c]+--+-- >>> [a,b,c] & _head %~ f+-- [f a,b,c]+--+-- >>> [] & _head %~ f+-- []+-- -- >>> [1,2,3]^?!_head -- 1 --@@ -46,22 +63,33 @@ -- -- >>> [0,1] & _head .~ 2 -- [2,1]+--+-- _head :: SimpleIndexedTraversal Int [a] a-_head = index $ \f aas -> case aas of+_head = indexed $ \f aas -> case aas of (a:as) -> (:as) <$> f (0 :: Int) a _ -> pure aas {-# INLINE _head #-} -- | A 'Traversal' reading and writing to the 'tail' of a /non-empty/ list --+-- >>> [a,b] & _tail .~ [c,d,e]+-- [a,c,d,e]+--+-- >>> [] & _tail .~ [a,b]+-- []+--+-- >>> [a,b,c,d,e] & _tail.traverse %~ f+-- [a,f b,f c,f d,f e]+-- -- >>> [1,2] & _tail .~ [3,4,5] -- [1,3,4,5] -- -- >>> [] & _tail .~ [1,2] -- [] ----- >>> [1,2,3]^?_tail--- Just [2,3]+-- >>> [a,b,c]^?_tail+-- Just [b,c] -- -- >>> [1,2]^?!_tail -- [2]@@ -78,12 +106,15 @@ -- | A 'Traversal' reading and writing to the last element of a /non-empty/ list ----- >>> [1,2,3]^?!_last--- 3+-- >>> [a,b,c]^?!_last+-- c -- -- >>> []^?_last -- Nothing --+-- >>> [a,b,c] & _last %~ f+-- [a,b,f c]+-- -- >>> [1,2]^?_last -- Just 2 --@@ -96,29 +127,35 @@ -- >>> [0,1] & _last .~ 2 -- [0,2] _last :: SimpleIndexedTraversal Int [a] a-_last = index $ \f aas -> case aas of+_last = indexed $ \f aas -> case aas of [] -> pure aas- (a:as) -> let go !n b [] = return <$> f n b- go !n b (c:cs) = (b:) <$> go (n + 1) c cs+ (a:as) -> let go n b [] = return <$> f n b+ go n b (c:cs) = (b:) <$> (go $! n + 1) c cs in go (0 :: Int) a as {-# INLINE _last #-} -- | A 'Traversal' reading and replacing all but the a last element of a /non-empty/ list ----- >>> [1,2,3,4]^?!_init--- [1,2,3]+-- >>> [a,b,c,d]^?_init+-- Just [a,b,c] ----- >>> [1,2] & _init .~ [3,4,5]--- [3,4,5,2]+-- >>> []^?_init+-- Nothing ----- >>> [] & _init .~ [1,2]+-- >>> [a,b] & _init .~ [c,d,e]+-- [c,d,e,b]+--+-- >>> [] & _init .~ [a,b] -- [] --+-- >>> [a,b,c,d] & _init.traverse %~ f+-- [f a,f b,f c,d]+-- -- >>> [1,2,3]^?_init -- Just [1,2] ----- >>> [1,2]^?!_init--- [1]+-- >>> [1,2,3,4]^?!_init+-- [1,2,3] -- -- >>> "hello"^._init -- "hell"@@ -129,3 +166,19 @@ _init _ [] = pure [] _init f as = (++ [Prelude.last as]) <$> f (Prelude.init as) {-# INLINE _init #-}++-- | A 'Prism' stripping a prefix from a list when used as a 'Traversal', or+-- prepending that prefix when run backwards:+--+-- >>> "preview" ^? strippingPrefix "pre"+-- Just "view"+--+-- >>> "review" ^? strippingPrefix "pre"+-- Nothing+--+-- >>> "amble"^.remit (strippingPrefix "pre")+-- "preamble"+strippingPrefix :: Eq a => [a] -> Simple Prism [a] [a]+strippingPrefix ps = prism (ps ++) $ \xs -> case stripPrefix ps xs of+ Nothing -> Left xs+ Just xs' -> Right xs'
src/Data/List/Split/Lens.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} ----------------------------------------------------------------------------@@ -163,15 +162,15 @@ -- | Modify or retrieve the list of delimiters for a 'Splitter'. delimiters :: Lens (Splitter a) (Splitter b) [a -> Bool] [b -> Bool]-delimiters f s@Splitter { delimiter = Delimiter ds } = (\ds' -> s { delimiter = Delimiter ds' }) <$> f ds+delimiters f s@Splitter { delimiter = Delimiter ds } = f ds <&> \ds' -> s { delimiter = Delimiter ds' } -- | Modify or retrieve the policy for what a 'Splitter' to do with delimiters. delimiting :: Simple Lens (Splitter a) DelimPolicy-delimiting f s@Splitter { delimPolicy = p } = (\p' -> s { delimPolicy = p' }) <$> f p+delimiting f s@Splitter { delimPolicy = p } = f p <&> \p' -> s { delimPolicy = p' } -- | Modify or retrieve the policy for what a 'Splitter' should about consecutive delimiters. condensing :: Simple Lens (Splitter a) Bool-condensing f s@Splitter { condensePolicy = p } = (\p' -> s { condensePolicy = i p' }) <$> f (o p) where+condensing f s@Splitter { condensePolicy = p } = f (o p) <&> \p' -> s { condensePolicy = i p' } where i True = Condense i False = KeepBlankFields o Condense = True@@ -179,11 +178,11 @@ -- | Modify or retrieve the policy for whether a 'Splitter' should drop an initial blank. keepInitialBlanks :: Simple Lens (Splitter a) Bool-keepInitialBlanks f s@Splitter { initBlankPolicy = p } = (\p' -> s { initBlankPolicy = end p' }) <$> f (keeps p)+keepInitialBlanks f s@Splitter { initBlankPolicy = p } = f (keeps p) <&> \p' -> s { initBlankPolicy = end p' } -- | Modify or retrieve the policy for whether a 'Splitter' should drop a final blank. keepFinalBlanks :: Simple Lens (Splitter a) Bool-keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = (\p' -> s { finalBlankPolicy = end p' }) <$> f (keeps p)+keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = f (keeps p) <&> \p' -> s { finalBlankPolicy = end p' } -- utilities
− src/Data/Monoid/Lens.hs
@@ -1,133 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Monoid.Lens--- Copyright : (C) 2012 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : Rank2Types---------------------------------------------------------------------------------module Data.Monoid.Lens- (- -- * Monoid Lens Operators- (<>~), (<<>~)- , (<>=), (<<>=)- -- * Isomorphisms for Monoidal Wrappers- , _dual, _endo, _all, _any, _sum, _product, _first, _last- ) where--import Data.Monoid-import Control.Lens-import Control.Monad.State as State---- $setup--- >>> :m + Control.Lens Data.Monoid.Lens Data.Foldable--infixr 4 <>~, <<>~-infix 4 <>=, <<>=---- | Modify the target of a monoidally valued by 'mappend'ing another value.------ >>> both <>~ "!!!" $ ("hello","world")--- ("hello!!!","world!!!")------ @--- ('<>~') :: 'Monoid' a => 'Setter' s t a a -> a -> s -> t--- ('<>~') :: 'Monoid' a => 'Iso' s t a a -> a -> s -> t--- ('<>~') :: 'Monoid' a => 'Lens' s t a a -> a -> s -> t--- ('<>~') :: 'Monoid' a => 'Traversal' s t a a -> a -> s -> t--- @-(<>~) :: Monoid a => Setting s t a a -> a -> s -> t-l <>~ n = over l (`mappend` n)-{-# INLINE (<>~) #-}---- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value.------ >>> execState (both <>= "!!!") ("hello","world")--- ("hello!!!","world!!!")------ @--- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Setter' s a -> a -> m ()--- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Iso' s a -> a -> m ()--- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Lens' s a -> a -> m ()--- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Traversal' s a -> a -> m ()--- @-(<>=) :: (MonadState s m, Monoid a) => SimpleSetting s a -> a -> m ()-l <>= a = State.modify (l <>~ a)-{-# INLINE (<>=) #-}----- | 'mappend' a monoidal value onto the end of the target of a 'Lens' and--- return the result------ When you do not need the result of the operation, ('<>~') is more flexible.-(<<>~) :: Monoid m => LensLike ((,)m) s t m m -> m -> s -> (m, t)-l <<>~ m = l <%~ (`mappend` m)-{-# INLINE (<<>~) #-}---- | 'mappend' a monoidal 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, ('<>=') is more flexible.-(<<>=) :: (MonadState s m, Monoid r) => SimpleLensLike ((,)r) s r -> r -> m r-l <<>= r = l <%= (`mappend` r)-{-# INLINE (<<>=) #-}---- | Isomorphism for 'Dual'-_dual :: Iso a b (Dual a) (Dual b)-_dual = isos Dual getDual Dual getDual-{-# INLINE _dual #-}---- | Isomorphism for 'Endo'-_endo :: Iso (a -> a) (b -> b) (Endo a) (Endo b)-_endo = isos Endo appEndo Endo appEndo-{-# INLINE _endo #-}---- | Isomorphism for 'All'------ >>> ala _all foldMap [True,True]--- True------ >>> ala _all foldMap [True,False]--- False-_all :: Simple Iso Bool All-_all = iso All getAll-{-# INLINE _all #-}---- | Isomorphism for 'Any'------ >>> ala _any foldMap [False,False]--- False------ >>> ala _any foldMap [True,False]--- True-_any :: Simple Iso Bool Any-_any = iso Any getAny-{-# INLINE _any #-}---- | Isomorphism for 'Sum'------ >>> ala _sum foldMap [1,2,3,4]--- 10-_sum :: Iso a b (Sum a) (Sum b)-_sum = isos Sum getSum Sum getSum-{-# INLINE _sum #-}---- | Isomorphism for 'Product'------ >>> ala _product foldMap [1,2,3,4]--- 24-_product :: Iso a b (Product a) (Product b)-_product = isos Product getProduct Product getProduct-{-# INLINE _product #-}---- | Isomorphism for 'First'-_first :: Iso (Maybe a) (Maybe b) (First a) (First b)-_first = isos First getFirst First getFirst-{-# INLINE _first #-}---- | Isomorphism for 'Last'-_last :: Iso (Maybe a) (Maybe b) (Last a) (Last b)-_last = isos Last getLast Last getLast-{-# INLINE _last #-}
src/Data/Sequence/Lens.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Sequence.Lens -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Sequence.Lens@@ -19,50 +20,104 @@ ) where import Control.Applicative-import Control.Lens as Lens+import Control.Lens import Data.Monoid import Data.Sequence as Seq +-- $setup+-- >>> import Debug.SimpleReflect.Expr+-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g+ -- | A 'Lens' that can access the @n@th element of a 'Seq'. ----- Note: This is only a legal lens if there is already such an element!+-- >>> Seq.fromList [a,b,c,d] & ordinal 2 %~ f+-- fromList [a,b,f c,d]+--+-- >>> Seq.fromList [a,b,c,d] & ordinal 2 .~ e+-- fromList [a,b,e,d]+--+-- >>> Seq.fromList [a,b,c,d] ^. ordinal 2+-- c+--+-- *NB:* This is only a legal lens if there is already such an element! ordinal :: Int -> SimpleIndexedLens Int (Seq a) a-ordinal i = Lens.index $ \ f m -> (\a -> update i a m) <$> f i (Seq.index m i)+ordinal i = indexed $ \ f m -> f i (index m i) <&> \a -> update i a m -- * Sequence isomorphisms -- | A 'Seq' is isomorphic to a 'ViewL' ----- @'viewl' m = m '^.' 'viewL'@+-- @'viewl' m ≡ m '^.' 'viewL'@+--+-- >>> Seq.fromList [a,b,c] ^. viewL+-- a :< fromList [b,c]+--+-- >>> Seq.empty ^. viewL+-- EmptyL+--+-- >>> EmptyL ^. from viewL+-- fromList []+--+-- >>> from viewL ^$ a :< fromList [b,c]+-- fromList [a,b,c]+-- viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b)-viewL = isos viewl unviewl viewl unviewl where--unviewl :: ViewL a -> Seq a-unviewl EmptyL = mempty-unviewl (a :< as) = a <| as+viewL = iso viewl $ \ xs -> case xs of+ EmptyL -> mempty+ a :< as -> a <| as {-# INLINE viewL #-} -- | A 'Seq' is isomorphic to a 'ViewR' ----- @'viewr' m = m '^.' 'viewR'@+-- @'viewr' m ≡ m '^.' 'viewR'@+--+-- >>> Seq.fromList [a,b,c] ^. viewR+-- fromList [a,b] :> c+--+-- >>> Seq.empty ^. viewR+-- EmptyR+--+-- >>> EmptyR ^. from viewR+-- fromList []+--+-- >>> from viewR ^$ fromList [a,b] :> c+-- fromList [a,b,c] viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b)-viewR = isos viewr unviewr viewr unviewr where+viewR = iso viewr $ \xs -> case xs of+ EmptyR -> mempty+ as :> a -> as |> a {-# INLINE viewR #-} -unviewr :: ViewR a -> Seq a-unviewr EmptyR = mempty-unviewr (as :> a) = as |> a- -- * Traversals -- | Traverse the head of a 'Seq'+--+-- >>> fromList [a,b,c,d] & _head %~ f+-- fromList [f a,b,c,d]+--+-- >>> fromList [] ^? _head+-- Nothing+--+-- >>> fromList [a,b,c,d] ^? _head+-- Just a _head :: SimpleIndexedTraversal Int (Seq a) a-_head = Lens.index $ \f m -> case viewl m of+_head = indexed $ \f m -> case viewl m of a :< as -> (<| as) <$> f (0::Int) a EmptyL -> pure m {-# INLINE _head #-} -- | Traverse the tail of a 'Seq'+--+-- >>> fromList [a,b] & _tail .~ fromList [c,d,e]+-- fromList [a,c,d,e]+--+-- >>> fromList [a,b,c] ^? _tail+-- Just (fromList [b,c])+--+-- >>> fromList [] ^? _tail+-- Nothing _tail :: SimpleTraversal (Seq a) (Seq a) _tail f m = case viewl m of a :< as -> (a <|) <$> f as@@ -70,13 +125,31 @@ {-# INLINE _tail #-} -- | Traverse the last element of a 'Seq'+--+-- >>> fromList [a,b,c,d] & _last %~ f+-- fromList [a,b,c,f d]+--+-- >>> fromList [a,b,c,d] ^? _last+-- Just d+--+-- >>> fromList [] ^? _last+-- Nothing _last :: SimpleIndexedTraversal Int (Seq a) a-_last = Lens.index $ \f m -> case viewr m of+_last = indexed $ \f m -> case viewr m of as :> a -> (as |>) <$> f (Seq.length as) a EmptyR -> pure m {-# INLINE _last #-} -- | Traverse all but the last element of a 'Seq'+--+-- >>> fromList [1,2,3] ^? _init+-- Just (fromList [1,2])+--+-- >>> fromList [a,b,c,d] & _init.traverse %~ f+-- fromList [f a,f b,f c,d]+--+-- >>> fromList [] & _init .~ fromList [a,b,c]+-- fromList [] _init :: SimpleTraversal (Seq a) (Seq a) _init f m = case viewr m of as :> a -> (|> a) <$> f as@@ -84,20 +157,47 @@ {-# INLINE _init #-} -- | Traverse the first @n@ elements of a 'Seq'+--+-- >>> fromList [a,b,c,d,e] ^.. slicedTo 2+-- [a,b]+--+-- >>> fromList [a,b,c,d,e] & slicedTo 2 %~ f+-- fromList [f a,f b,c,d,e]+--+-- >>> fromList [a,b,c,d,e] & slicedTo 10 .~ x+-- fromList [x,x,x,x,x] slicedTo :: Int -> SimpleIndexedTraversal Int (Seq a) a-slicedTo n = Lens.index $ \f m -> case Seq.splitAt n m of+slicedTo n = indexed $ \f m -> case Seq.splitAt n m of (l,r) -> (>< r) <$> itraverse f l {-# INLINE slicedTo #-} -- | Traverse all but the first @n@ elements of a 'Seq'+--+-- >>> fromList [a,b,c,d,e] ^.. slicedFrom 2+-- [c,d,e]+--+-- >>> fromList [a,b,c,d,e] & slicedFrom 2 %~ f+-- fromList [a,b,f c,f d,f e]+--+-- >>> fromList [a,b,c,d,e] & slicedFrom 10 .~ x+-- fromList [a,b,c,d,e] slicedFrom :: Int -> SimpleIndexedTraversal Int (Seq a) a-slicedFrom n = Lens.index $ \ f m -> case Seq.splitAt n m of+slicedFrom n = indexed $ \ f m -> case Seq.splitAt n m of (l,r) -> (l ><) <$> itraverse (f . (+n)) r {-# INLINE slicedFrom #-} --- | Travere all the elements numbered from @i@ to @j@ of a 'Seq'+-- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq'+--+-- >>> fromList [a,b,c,d,e] & sliced 1 3 %~ f+-- fromList [a,f b,f c,d,e]++-- >>> fromList [a,b,c,d,e] ^.. sliced 1 3+-- [f b,f c]+--+-- >>> fromList [a,b,c,d,e] & sliced 1 3 .~ x+-- fromList [a,x,x,b,e] sliced :: Int -> Int -> SimpleIndexedTraversal Int (Seq a) a-sliced i j = Lens.index $ \ f s -> case Seq.splitAt i s of+sliced i j = indexed $ \ f s -> case Seq.splitAt i s of (l,mr) -> case Seq.splitAt (j-i) mr of- (m, r) -> (\n -> l >< n >< r) <$> itraverse (f . (+i)) m+ (m, r) -> itraverse (f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-}
src/Data/Set/Lens.hs view
@@ -14,8 +14,8 @@ , setOf ) where -import Control.Lens.Getter-import Control.Lens.Setter+import Control.Lens.Getter ( Getting, views )+import Control.Lens.Setter ( Setter, sets ) import Data.Set as Set -- $setup
src/Data/Text/Lazy/Lens.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE FlexibleInstances #-}+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -10,8 +11,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lazy.Lens
src/Data/Text/Lens.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -9,8 +10,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lens
src/Data/Text/Strict/Lens.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -9,8 +10,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Strict.Lens
src/Data/Tree/Lens.hs view
@@ -23,14 +23,13 @@ -- -- >>> view root $ Node 42 [] -- 42-root :: Simple Lens (Tree a) a+root :: SimpleLens (Tree a) a root f (Node a as) = (`Node` as) <$> f a {-# INLINE root #-} --- | A 'Traversal' of the direct descendants of the root of a 'Tree'--- indexed by its position in the list of children+-- | A 'Lens' returning the direct descendants of the root of a 'Tree' ----- @'toListOf' 'branches' ≡ 'subForest'@-branches :: SimpleIndexedTraversal Int (Tree a) (Tree a)-branches = index $ \ f (Node a as) -> Node a <$> itraverse f as+-- @'view' 'branches' ≡ 'subForest'@+branches :: SimpleLens (Tree a) [Tree a]+branches f (Node a as) = Node a <$> f as {-# INLINE branches #-}
src/Data/Typeable/Lens.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -21,18 +21,18 @@ import Control.Applicative import Control.Lens import Data.Typeable-import Unsafe.Coerce as Unsafe+import Data.Maybe -- | A 'Simple' 'Traversal' for working with a 'cast' of a 'Typeable' value. _cast :: (Typeable s, Typeable a) => Simple Traversal s a _cast f s = case cast s of- Just a -> Unsafe.unsafeCoerce <$> f a+ Just a -> fromMaybe (error "_cast: recast failed") . cast <$> f a Nothing -> pure s {-# INLINE _cast #-} -- | A 'Simple' 'Traversal' for working with a 'gcast' of a 'Typeable' value. _gcast :: (Typeable s, Typeable a) => Simple Traversal (c s) (c a) _gcast f s = case gcast s of- Just a -> Unsafe.unsafeCoerce <$> f a+ Just a -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a Nothing -> pure s {-# INLINE _gcast #-}
src/Data/Vector/Generic/Lens.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------@@ -38,11 +38,10 @@ , ordinals ) where -import Control.Applicative import Control.Lens import Data.List (nub) import Data.Monoid-import Data.Vector.Generic as V hiding (zip, filter)+import Data.Vector.Generic as V hiding (zip, filter, indexed) import Data.Vector.Fusion.Stream (Stream) import Data.Vector.Generic.New (New) import Prelude hiding ((++), length, head, tail, init, last, map, reverse)@@ -57,7 +56,7 @@ -- >>> Vector.fromList [1,2,3]^._head -- 1 _head :: Vector v a => SimpleLens (v a) a-_head f v = (\a -> v // [(0,a)]) <$> f (head v)+_head f v = f (head v) <&> \a -> v // [(0,a)] {-# INLINE _head #-} -- | A 'Lens' reading and writing to the 'last' element of a /non-empty/ 'Vector'@@ -67,7 +66,7 @@ -- >>> Vector.fromList [1,2]^._last -- 2 _last :: Vector v a => SimpleLens (v a) a-_last f v = (\a -> v // [(length v - 1, a)]) <$> f (last v)+_last f v = f (last v) <&> \a -> v // [(length v - 1, a)] {-# INLINE _last #-} -- | A lens reading and writing to the 'tail' of a /non-empty/ 'Vector'@@ -77,7 +76,7 @@ -- >>> _tail .~ Vector.fromList [3,4,5] $ Vector.fromList [1,2] -- fromList [1,3,4,5] _tail :: Vector v a => SimpleLens (v a) (v a)-_tail f v = cons (head v) <$> f (tail v)+_tail f v = f (tail v) <&> cons (head v) {-# INLINE _tail #-} -- | A 'Lens' reading and replacing all but the a 'last' element of a /non-empty/ 'Vector'@@ -87,7 +86,7 @@ -- >>> Vector.fromList [1,2,3,4]^._init -- fromList [1,2,3] _init :: Vector v a => SimpleLens (v a) (v a)-_init f v = (`snoc` last v) <$> f (init v)+_init f v = f (init v) <&> \i -> snoc i (last v) {-# INLINE _init #-} -- | @sliced i n@ provides a lens that edits the @n@ elements starting at index @i@ from a lens.@@ -98,7 +97,7 @@ sliced :: Vector v a => Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> SimpleLens (v a) (v a)-sliced i n f v = (\ v0 -> v // zip [i..i+n-1] (V.toList v0)) <$> f (slice i n v)+sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (V.toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'.@@ -140,7 +139,7 @@ -- -- @ordinal n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. ordinal :: Vector v a => Int -> SimpleIndexedLens Int (v a) a-ordinal i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i)+ordinal i = indexed $ \ f v -> f i (v ! i) <&> \ a -> v // [(i, a)] {-# INLINE ordinal #-} -- | This 'Traversal' will ignore any duplicates in the supplied list of indices.@@ -148,7 +147,7 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: Vector v a => [Int] -> SimpleIndexedTraversal Int (v a) a-ordinals is = index $ \ f v -> let+ordinals is = indexed $ \ f v -> let l = length v is' = nub $ filter (<l) is in fmap ((v //) . zip is') . traverse (uncurry f) . zip is $ fmap (v !) is'
src/Data/Vector/Lens.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------@@ -35,9 +35,8 @@ , ordinals ) where -import Control.Applicative import Control.Lens-import Data.Vector as Vector hiding (zip, filter)+import Data.Vector as Vector hiding (zip, filter, indexed) import Prelude hiding ((++), length, head, tail, init, last, map, reverse) import Data.List (nub) import Data.Monoid@@ -49,7 +48,7 @@ -- >>> Vector.fromList [1,2,3]^._head -- 1 _head :: SimpleLens (Vector a) a-_head f v = (\a -> v // [(0,a)]) <$> f (head v)+_head f v = f (head v) <&> \a -> v // [(0,a)] {-# INLINE _head #-} -- | A 'Lens' reading and writing to the 'last' element of a /non-empty/ 'Vector'@@ -59,7 +58,7 @@ -- >>> Vector.fromList [1,2]^._last -- 2 _last :: SimpleLens (Vector a) a-_last f v = (\a -> v // [(length v - 1, a)]) <$> f (last v)+_last f v = f (last v) <&> \a -> v // [(length v - 1, a)] {-# INLINE _last #-} -- | A lens reading and writing to the 'tail' of a /non-empty/ 'Vector'@@ -69,7 +68,7 @@ -- >>> _tail .~ Vector.fromList [3,4,5] $ Vector.fromList [1,2] -- fromList [1,3,4,5] _tail :: SimpleLens (Vector a) (Vector a)-_tail f v = cons (head v) <$> f (tail v)+_tail f v = f (tail v) <&> cons (head v) {-# INLINE _tail #-} -- | A 'Lens' reading and replacing all but the a 'last' element of a /non-empty/ 'Vector'@@ -79,7 +78,7 @@ -- >>> Vector.fromList [1,2,3,4]^._init -- fromList [1,2,3] _init :: SimpleLens (Vector a) (Vector a)-_init f v = (`snoc` last v) <$> f (init v)+_init f v = f (init v) <&> (`snoc` last v) {-# INLINE _init #-} -- | @sliced i n@ provides a lens that edits the @n@ elements starting at index @i@ from a lens.@@ -90,7 +89,7 @@ sliced :: Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> SimpleLens (Vector a) (Vector a)-sliced i n f v = (\ v0 -> v // zip [i..i+n-1] (toList v0)) <$> f (slice i n v)+sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'.@@ -100,24 +99,24 @@ -- | Convert a list to a 'Vector' (or back) vector :: Iso [a] [b] (Vector a) (Vector b)-vector = isos fromList toList fromList toList+vector = iso fromList toList {-# INLINE vector #-} -- | Convert a 'Vector' to a version with all the elements in the reverse order reversed :: Iso (Vector a) (Vector b) (Vector a) (Vector b)-reversed = isos reverse reverse reverse reverse+reversed = iso reverse reverse {-# INLINE reversed #-} -- | Convert a 'Vector' to a version that doesn't retain any extra memory. forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b)-forced = isos force force force force+forced = iso force force {-# INLINE forced #-} -- | This is a more efficient version of 'element' that works for any 'Vector'. -- -- @ordinal n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. ordinal :: Int -> SimpleIndexedLens Int (Vector a) a-ordinal i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i)+ordinal i = indexed $ \ f v -> f i (v ! i) <&> \ a -> v // [(i, a)] {-# INLINE ordinal #-} -- | This 'Traversal' will ignore any duplicates in the supplied list of indices.@@ -125,7 +124,7 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: [Int] -> SimpleIndexedTraversal Int (Vector a) a-ordinals is = index $ \ f v -> let+ordinals is = indexed $ \ f v -> let l = length v is' = nub $ filter (<l) is in fmap ((v //) . zip is') . traverse (uncurry f) . zip is $ fmap (v !) is'
src/GHC/Generics/Lens.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-}-{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens@@ -22,6 +24,11 @@ -- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to' from @GHC.Generics@, -- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@ -- in code that uses generics.+--+-- If you're using a version of GHC older than 7.2, this module is+-- compatible with the+-- <http://hackage.haskell.org/package/generic-deriving generic-deriving>+-- package. ---------------------------------------------------------------------------- module GHC.Generics.Lens (@@ -37,8 +44,13 @@ import Control.Lens hiding (Rep) import Data.Maybe (fromJust) import Data.Typeable+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import qualified GHC.Generics as Generic-import GHC.Generics hiding (from, to)+import GHC.Generics hiding (from, to)+#else+import qualified Generics.Deriving as Generic+import Generics.Deriving hiding (from, to)+#endif -- | Convert from the data type to its representation (or back) --@@ -52,7 +64,7 @@ generic1 :: Generic1 f => Simple Iso (f a) (Rep1 f a) generic1 = iso from1 to1 --- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurence+-- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurrence -- of something 'Typeable' anywhere in a container. -- -- >>> allOf tinplate (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"])
src/Language/Haskell/TH/Lens.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif@@ -29,9 +28,10 @@ import Control.Lens.Getter import Control.Lens.Setter import Control.Lens.Fold+import Control.Lens.IndexedLens+import Control.Lens.IndexedTraversal import Control.Lens.Type import Control.Lens.Traversal-import Control.Lens.IndexedLens import Data.Map as Map hiding (toList,map) import Data.Maybe (fromMaybe) import Data.Monoid@@ -96,7 +96,7 @@ -- | Substitute using a map of names in for /free/ type variables substTypeVars :: HasTypeVars t => Map Name Name -> t -> t-substTypeVars m = mapOf typeVars $ \n -> fromMaybe n (m^.at n)+substTypeVars m = over typeVars $ \n -> fromMaybe n (m^.at n) -- | Provides substitution for types class SubstType t where
tests/hunit.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module Main where @@ -6,7 +7,6 @@ import Data.Char import Data.List as List import Data.Monoid-import Data.Monoid.Lens import Data.Map as Map import Test.Framework.Providers.HUnit import Test.Framework.TH
tests/properties.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -13,12 +16,15 @@ import Test.QuickCheck.All import Test.QuickCheck.Function import Data.Text.Strict.Lens+import Data.List.Lens+import Data.Functor.Compose + setter_id :: Eq s => Simple Setter s a -> s -> Bool setter_id l s = runIdentity (l Identity s) == s setter_composition :: Eq s => Simple Setter s a -> s -> Fun a a -> Fun a a -> Bool-setter_composition l s (Fun _ f) (Fun _ g) = mapOf l f (mapOf l g s) == mapOf l (f . g) s+setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s lens_set_view :: Eq s => Simple Lens s a -> s -> Bool lens_set_view l s = set l (view l s) s == s@@ -29,19 +35,40 @@ setter_set_set :: Eq s => Simple Setter s a -> s -> a -> a -> Bool setter_set_set l s a b = set l b (set l a s) == set l b s -iso_hither :: Eq s => Simple Iso s a -> s -> Bool-iso_hither l s = s ^.l.from l == s+iso_hither :: Eq s => Simple AnIso s a -> s -> Bool+iso_hither l s = s ^.cloneIso l.from l == s -iso_yon :: Eq a => Simple Iso s a -> a -> Bool-iso_yon l a = a^.from l.l == a+iso_yon :: Eq a => Simple AnIso s a -> a -> Bool+iso_yon l a = a^.from l.cloneIso l == a +prism_yen :: Eq a => Simple APrism s a -> a -> Bool+prism_yen l a = a^.remit l^?clonePrism l == Just a++traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => SimpleLensLike f s a -> s -> Bool+traverse_pure l s = l pure s == (pure s :: f s)++traverse_pureMaybe :: Eq s => SimpleLensLike Maybe s a -> s -> Bool+traverse_pureMaybe = traverse_pure++traverse_pureList :: Eq s => SimpleLensLike [] s a -> s -> Bool+traverse_pureList = traverse_pure++traverse_compose :: (Applicative f, Applicative g, Eq (f (g s)))+ => Simple Traversal s a -> (a -> g a) -> (a -> f a) -> s -> Bool+traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s+ isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) => Simple Setter s a -> Property isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) => Simple Traversal s a -> Property-isTraversal l = isSetter l+isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l+ .&. do as <- arbitrary+ bs <- arbitrary+ t <- arbitrary+ property $ traverse_compose l (\x -> as++[x]++bs)+ (\x -> if t then Just x else Nothing) isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) => Simple Lens s a -> Property@@ -51,6 +78,10 @@ => Simple Iso s a -> Property isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) +isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)+ => Simple Prism s a -> Property+isPrism l = isTraversal l .&. prism_yen l+ -- an illegal lens bad :: Simple Lens (Int,Int) Int bad f (a,b) = (,) b <$> f a@@ -81,8 +112,19 @@ prop_traverseLeft = isTraversal (_left :: Simple Traversal (Either Int Bool) Int) prop_traverseRight = isTraversal (_right :: Simple Traversal (Either Int Bool) Bool) +prop_simple = isIso (simple :: Simple Iso Int Int)+--prop_enum = isIso (enum :: Simple Iso Int Char)++prop__left = isPrism (_left :: Simple Prism (Either Int Bool) Int)+prop__right = isPrism (_right :: Simple Prism (Either Int Bool) Bool)+prop__just = isPrism (_just :: Simple Prism (Maybe Int) Int)++-- Data.List.Lens+prop_strippingPrefix s = isPrism (strippingPrefix s :: Simple Prism String String)+ -- Data.Text.Lens prop_text s = s^.packed.from packed == s+--prop_text = isIso packed main :: IO () main = do
tests/templates.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-} -- | The commented code summarizes what will be auto-generated below module Main where @@ -54,7 +59,7 @@ makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task -data Mono = Mono { _monoFoo :: Int, _monoBar :: Int }+data Mono a = Mono { _monoFoo :: a, _monoBar :: Int } makeClassy ''Mono -- class HasMono t where -- mono :: Simple Lens t Mono@@ -63,14 +68,14 @@ -- monoFoo :: HasMono t => Simple Lens t Int -- monoBar :: HasMono t => Simple Lens t Int -data Nucleosis = Nucleosis { _nuclear :: Mono }+data Nucleosis = Nucleosis { _nuclear :: Mono Int } makeClassy ''Nucleosis -- class HasNucleosis t where -- nucleosis :: Simple Lens t Nucleosis -- instance HasNucleosis Nucleosis -- nuclear :: HasNucleosis t => Simple Lens t Mono -instance HasMono Nucleosis where+instance HasMono Nucleosis Int where mono = nuclear -- Dodek's example