lens 3.10.3 → 4.0
raw patch · 107 files changed
+7480/−3470 lines, 107 filesdep +aesondep +constraintsdep +exceptionsdep −MonadCatchIO-transformersdep ~basedep ~contravariantdep ~generic-derivingbinary-added
Dependencies added: aeson, constraints, exceptions, hlint, primitive, scientific, utf8-string, zlib
Dependencies removed: MonadCatchIO-transformers
Dependency ranges changed: base, contravariant, generic-deriving, semigroupoids
Files
- .gitignore +4/−1
- .travis.yml +45/−13
- AUTHORS.markdown +1/−1
- CHANGELOG.markdown +34/−9
- HLint.hs +37/−0
- LICENSE +1/−1
- README.markdown +3/−3
- SUPPORT.markdown +10/−0
- images/overview.png binary
- lens-properties/CHANGELOG.markdown +9/−0
- lens-properties/LICENSE +27/−0
- lens-properties/Setup.hs +2/−0
- lens.cabal +58/−22
- src/Codec/Compression/Zlib/Lens.hs +231/−0
- src/Control/Exception/Lens.hs +209/−182
- src/Control/Lens.hs +3/−7
- src/Control/Lens/Action.hs +15/−15
- src/Control/Lens/At.hs +162/−295
- src/Control/Lens/Combinators.hs +137/−64
- src/Control/Lens/Cons.hs +103/−48
- src/Control/Lens/Each.hs +86/−176
- src/Control/Lens/Empty.hs +160/−0
- src/Control/Lens/Equality.hs +4/−4
- src/Control/Lens/Extras.hs +34/−0
- src/Control/Lens/Fold.hs +183/−39
- src/Control/Lens/Getter.hs +27/−28
- src/Control/Lens/Indexed.hs +64/−59
- src/Control/Lens/Internal.hs +1/−1
- src/Control/Lens/Internal/Action.hs +10/−5
- src/Control/Lens/Internal/Bazaar.hs +149/−1
- src/Control/Lens/Internal/ByteString.hs +1/−1
- src/Control/Lens/Internal/Context.hs +2/−2
- src/Control/Lens/Internal/Deque.hs +4/−4
- src/Control/Lens/Internal/Exception.hs +48/−31
- src/Control/Lens/Internal/Fold.hs +30/−1
- src/Control/Lens/Internal/Getter.hs +99/−26
- src/Control/Lens/Internal/Indexed.hs +3/−3
- src/Control/Lens/Internal/Instances.hs +2/−12
- src/Control/Lens/Internal/Iso.hs +1/−1
- src/Control/Lens/Internal/Level.hs +1/−2
- src/Control/Lens/Internal/Magma.hs +1/−2
- src/Control/Lens/Internal/Prism.hs +1/−1
- src/Control/Lens/Internal/Reflection.hs +202/−0
- src/Control/Lens/Internal/Review.hs +4/−131
- src/Control/Lens/Internal/Setter.hs +1/−79
- src/Control/Lens/Internal/TH.hs +48/−0
- src/Control/Lens/Internal/TupleIxedTH.hs +103/−0
- src/Control/Lens/Internal/Zipper.hs +0/−875
- src/Control/Lens/Internal/Zoom.hs +2/−3
- src/Control/Lens/Iso.hs +52/−18
- src/Control/Lens/Lens.hs +226/−52
- src/Control/Lens/Level.hs +3/−4
- src/Control/Lens/Loupe.hs +1/−1
- src/Control/Lens/Operators.hs +133/−95
- src/Control/Lens/Plated.hs +21/−15
- src/Control/Lens/Prism.hs +71/−18
- src/Control/Lens/Reified.hs +428/−13
- src/Control/Lens/Review.hs +28/−10
- src/Control/Lens/Setter.hs +55/−20
- src/Control/Lens/Simple.hs +0/−69
- src/Control/Lens/TH.hs +639/−164
- src/Control/Lens/Traversal.hs +178/−28
- src/Control/Lens/Tuple.hs +242/−58
- src/Control/Lens/Type.hs +78/−21
- src/Control/Lens/Wrapped.hs +386/−248
- src/Control/Lens/Zipper.hs +0/−95
- src/Control/Lens/Zoom.hs +1/−1
- src/Control/Monad/Error/Lens.hs +2/−3
- src/Control/Monad/Primitive/Lens.hs +27/−0
- src/Control/Parallel/Strategies/Lens.hs +1/−1
- src/Control/Seq/Lens.hs +1/−1
- src/Data/Aeson/Lens.hs +348/−0
- src/Data/Array/Lens.hs +1/−1
- src/Data/Bits/Lens.hs +21/−5
- src/Data/ByteString/Lazy/Lens.hs +1/−1
- src/Data/ByteString/Lens.hs +1/−1
- src/Data/ByteString/Strict/Lens.hs +1/−2
- src/Data/Complex/Lens.hs +1/−1
- src/Data/Data/Lens.hs +37/−54
- src/Data/Dynamic/Lens.hs +1/−1
- src/Data/HashSet/Lens.hs +1/−1
- src/Data/IntSet/Lens.hs +1/−1
- src/Data/List/Lens.hs +1/−1
- src/Data/List/Split/Lens.hs +7/−1
- src/Data/Map/Lens.hs +57/−0
- src/Data/Sequence/Lens.hs +21/−1
- src/Data/Set/Lens.hs +1/−1
- src/Data/Text/Lazy/Lens.hs +15/−1
- src/Data/Text/Lens.hs +1/−1
- src/Data/Text/Strict/Lens.hs +12/−1
- src/Data/Tree/Lens.hs +1/−1
- src/Data/Typeable/Lens.hs +1/−1
- src/Data/Vector/Generic/Lens.hs +1/−1
- src/Data/Vector/Lens.hs +1/−1
- src/GHC/Generics/Lens.hs +1/−1
- src/Generics/Deriving/Lens.hs +7/−9
- src/Language/Haskell/TH/Lens.hs +1791/−132
- src/Numeric/Lens.hs +54/−1
- src/System/Exit/Lens.hs +4/−4
- src/System/FilePath/Lens.hs +37/−6
- src/System/IO/Error/Lens.hs +14/−42
- tests/doctests.hsc +1/−1
- tests/hlint.hs +23/−0
- tests/hunit.hs +1/−1
- tests/properties.hs +2/−97
- tests/templates.hs +76/−8
- travis/cabal-apt-install +1/−6
.gitignore view
@@ -1,4 +1,5 @@-dist+dist/+.hsenv/ docs wiki TAGS@@ -11,3 +12,5 @@ *.hi *~ *#+.cabal-sandbox/+cabal.sandbox.config
.travis.yml view
@@ -1,18 +1,56 @@ language: haskell++env:+ - GHCVER=7.4.2+ - GHCVER=7.6.3+ - GHCVER=head+ # - >+ # GHCVER=7.4.2+ # MODE="-fsafe"++# Ingore 7.4.2 failures for now because of the doctest GHC panic.+matrix:+ allow_failures:+ - env: GHCVER=7.4.2+ - env: GHCVER=head+ before_install:+ # If $GHCVER is the one travis has, don't bother reinstalling it.+ # We can also have faster builds by installing some libraries with+ # `apt`. If it isn't, install the GHC we want from hvr's PPA along+ # with cabal-1.18.+ - |+ if [ $GHCVER = `ghc --numeric-version` ]; then+ # Try installing some of the build-deps with apt-get for speed.+ travis/cabal-apt-install --enable-tests $MODE+ export CABAL=cabal+ else+ # Install the GHC we want from hvr's PPA+ sudo add-apt-repository -y ppa:hvr/ghc+ sudo apt-get update+ sudo apt-get install cabal-install-1.18 ghc-$GHCVER+ export CABAL=cabal-1.18+ export PATH=/opt/ghc/$GHCVER/bin:$PATH+ fi # Uncomment whenever hackage is down.- # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update- - cabal update+ # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update+ - $CABAL update - # Try installing some of the build-deps with apt-get for speed.- - travis/cabal-apt-install $mode+ # Update happy when building with GHC head+ - | + if [ $GHCVER = "head" ]; then+ $CABAL install happy+ export PATH=$HOME/.cabal/bin:$PATH+ fi+ install:- - cabal configure -flib-Werror $mode- - cabal build+ - $CABAL install --dependencies-only --enable-tests+ - $CABAL configure -flib-Werror --enable-tests $MODE script:- - $script && hlint src --cpp-define HLINT+ - $CABAL build+ - $CABAL test --show-details=always - scripts/stats notifications:@@ -22,9 +60,3 @@ skip_join: true template: - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"--env:- - mode="--enable-tests" script="cabal test --show-details=always"- # - 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"
AUTHORS.markdown view
@@ -19,7 +19,7 @@ * [Simon Hengel](mailto:sol@typeful.net) [@sol](https://github.com/sol) * [@startling](https://github.com/startling) * [Mike Ledger](mailto:eleventynine@gmail.com) [@mikeplus64](https://github.com/mikeplus64)-* \`nand\` [@nandykins](https://github.com/nandykins)+* [Niklas Haas](mailto:niklas.haas@uni-ulm.de) [@nandykins](https://github.com/nandykins) * [Adrian Keet](mailto:arkeet@gmail.com) [@arkeet](https://github.com/arkeet) * [Matvey B. Aksenov](mailto:matvey.aksenov@gmail.com) [@supki](https://github.com/supki) * [Eyal Lotem](mailto:eyal.lotem+github@gmail.com) [@Peaker](https://github.com/Peaker)
CHANGELOG.markdown view
@@ -1,12 +1,37 @@-3.10.3 [maintenance release]--------* Update `MonadCatchIO-transformers` to allow 0.3.1.2, and `contravariant`-to allow 1.1.--3.10.2 [maintenance release]--------* Explicitly disallow `MonadCatchIO-transformers` 0.3.1 as it imports-`monads-tf`, making for a bad user experience requiring package hiding.+4.0+----+* Added `nearly` to `Control.Lens.Prism`.+* Added `Control.Lens.Empty`, exporting `_Empty`.+* We now require `DefaultSignatures`.+* Added `failing` and `ifailing` to `Control.Lens.Traversal`.+* Changed the signature of `Data.List.Split.Lens.condensing` due to the addition of `DropBlankFields` to `Data.List.Split.CondensePolicy` in `split`.+* Simplified `Each`, `Ixed`, and `Contains`. They are no longer indexed. The previous design was actively getting in the way of user-defined instances.+* Replaced more of our home-grown types with standard ones. They had previously been defined to help make more intelligible error messages, but when we switched to using `(Contravariant f, Functor f)` instead of `(Gettable f)`, these no ceased to really help. Now you can define even more `lens`-compatible types (e.g. `Getter` and `Fold`) without depending on `lens`.+ * Replaced the use of `Accessor` with `Const`.+ * Replaced the use of `Mutator` with `Identity`.+ * Replaced the use of `Reviewed` with `Tagged`.+* Removed the deprecated `Control.Lens.Simple` module.+* Repurposed `Control.Lens.Combinators` to reëxport `Control.Lens` sans any operators; previous residents rehomed to `Control.Lens.Lens`.+* Added `Control.Lens.Operators` to export just the operators. Varying your import styles between these supports many qualified usage scenarios.+* Simplified `Cons` and `Snoc`. Now they must be a `Prism`.+* Simplified `Contains`. This necessitated losing many instancs of `Contains`, but makes it much easier and more consistent to use and instantiate.+* Simplified the various `AsFoo` types in `Control.Exception.Lens`+* Simplified the types in `System.IO.Error.Lens`.+* Merged `lens-aeson` into `lens`.+* We're exiling `Control.Lens.Zipper` to a separate package. This will let the design for it iterate faster and let us explore the trade-offs between the 3.8 style and the 3.9 style of zippers.+* Generalized `alongside`, `inside`, `both`.+* Switched to a new `Typeable` version of `reflection` for the harder combinators in `Control.Exception.Lens`. This enables us to comply with GHC 7.7's ban on hand-written `Typeable` instances.+* Added a `_Show` `Prism`.+* Added `Control.Lens.Extras` for the combinator names we don't have the gall to claim outright, but which are consistent with the rest.+* Renamed the constructors for `ReifiedLens`, etc. to just be the name of their base type.+* Added many many missing instances for `ReifiedFold` and `ReifiedGetter`. This permits things like `runFold ((,) <$> Fold (traverse._1) <*> Fold (traverse._2))` to be a `Fold`+ and `ReifiedFold` can be used as a `Monad`, `Profunctor`, etc.+* Many performance optimizations.+* Switched to `exceptions` from `MonadCatchIO-transformers`+* Added types for working with `RelevantFold` and `RelevantTraversal`. These are a `Fold` or `Traversal` that always has at least one target. Since `Apply` isn't a superclass of `Applicative`, you occasionally need to convert between them, but it lets you more readily work with less unsafety.+* Changed `unwrapping` and `wrapping` to have the same constructor-oriented order as a `Prism` and renamed them t `_Wrapping` and `_Unwrapping` respectively. +* Drastically changed the way `_Wrapping` and `_Unwrapping` are built to get much better inference.+* There are about 15,000 lines of patches over the last year, so I'm sure we missed a few big changes. 3.10.1 [maintenance release] ------
+ HLint.hs view
@@ -0,0 +1,37 @@+import "hint" HLint.HLint++ignore "Reduce duplication"+ignore "Redundant lambda"+ignore "Use >=>"+ignore "Use const"++-- Used hlint --find src/ in the lens repo to generate this:+infixl 9 :>++infixr 9 <.>, <., .>, ...+infixr 9 #.++infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!+infixl 8 ^., ^@.+infixl 8 ^#+infixl 8 .#++infixr 8 ^!, ^@!++infixr 4 </>~, <</>~, <.>~, <<.>~+infixr 4 <#~, #~, #%~, <#%~, #%%~+infixr 4 .|.~, .&.~, <.|.~, <.&.~+infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~+infixr 4 %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~++infix 4 </>=, <</>=, <.>=, <<.>=+infix 4 <#=, #=, #%=, <#%=, #%%=+infix 4 .|.=, .&.=, <.|.=, <.&.=+infix 4 %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=+infix 4 %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=++infixr 2 `zoom`, `magnify`+infixr 2 <~+infixr 2 <<~++infixl 1 &, <&>, ??
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2012-2013 Edward Kmett+Copyright 2012-2014 Edward Kmett All rights reserved.
README.markdown view
@@ -95,13 +95,13 @@ This will automatically generate the following lenses: ```haskell-bar, baz :: Simple Lens (Foo a) Int+bar, baz :: Lens' (Foo a) Int quux :: Lens (Foo a) (Foo b) a b ``` A `Lens` takes 4 parameters because it can change the types of the whole when you change the type of the part. -Often you won't need this flexibility, a `Simple Lens` takes 2 parameters, and can be used directly as a `Lens`.+Often you won't need this flexibility, a `Lens'` takes 2 parameters, and can be used directly as a `Lens`. You can also write to setters that target multiple parts of a structure, or their composition with other lenses or setters. The canonical example of a setter is 'mapped':@@ -241,7 +241,7 @@ <td/> <td><a href="http://ekmett.github.com/lens/Control-Lens-Getter.html#v:use"><code>use</code></a>,<a href="http://ekmett.github.com/lens/Control-Lens-Getter.html#v:uses"><code>uses</code></a></td> <td/>- <td>View target(s). <a href="http://ekmett.github.com/lens/Control-Lens-Getter.html#v:query"><code>query</code></a> works like <a href="http://ekmett.github.com/lens/Control-Lens-Getter.html#v:use"><code>use</code></a> over a <code>MonadReader</code></td>+ <td>View target(s). <a href="http://ekmett.github.com/lens/Control-Lens-Getter.html#v:view"><code>view</code></a> works like <a href="http://ekmett.github.com/lens/Control-Lens-Getter.html#v:use"><code>use</code></a> over a <code>MonadReader</code></td> </tr> <tr> <td><a href="http://ekmett.github.com/lens/Control-Lens-Setter.html#v:set"><code>set</code></a>, <a href="http://ekmett.github.com/lens/Control-Lens-Setter.html#v:.-126-"><code>.~</code></a></td>
+ SUPPORT.markdown view
@@ -0,0 +1,10 @@+We currently maintain 2 versions of lens:++We have committed to supporting the 3.7.x branch until GHC 7.8 is released. This version is at 3.7.6 as of the time of this writing. After GHC 7.8 is released we'll continue to+support a version with GHC 7.4 support until the next major GHC release occurs. Practically this means that there should always be some version of lens in a supported configuration+across the last 3 major GHC releases at all times -- counting GHC 7.2 as a technology preview rather than a major release.++We also have committed to keeping the current version of lens up to date and building as part of [stackage](http://github.com/fpco/stackage).++--Edward Kmett+Fri Mar 29 16:11:41 EDT 2013
+ images/overview.png view
binary file changed (absent → 316113 bytes)
+ lens-properties/CHANGELOG.markdown view
@@ -0,0 +1,9 @@+4.0+---++* Initial release containing the properties:+ * `isIso`+ * `isLens`+ * `isPrism`+ * `isSetter`+ * `isTraversal`
+ lens-properties/LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2012-2014, Edward Kmett+Copyright (c) 2014, Oliver Charles++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ lens-properties/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
lens.cabal view
@@ -1,6 +1,6 @@ name: lens-category: Data, Lenses-version: 3.10.3+category: Data, Lenses, Generics+version: 4.0 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -9,8 +9,9 @@ stability: provisional homepage: http://github.com/ekmett/lens/ bug-reports: http://github.com/ekmett/lens/issues-copyright: Copyright (C) 2012-2013 Edward A. Kmett+copyright: Copyright (C) 2012-2014 Edward A. Kmett build-type: Custom+-- build-tools: cpphs tested-with: GHC == 7.6.3 synopsis: Lenses, Folds and Traversals description:@@ -22,16 +23,18 @@ families of getters, folds, isomorphisms, traversals, setters and lenses and their indexed variants. .- An overview, with a large number of examples can be found in the @README@: <https://github.com/ekmett/lens#lens-lenses-folds-and-traversals>+ An overview, with a large number of examples can be found in the <https://github.com/ekmett/lens#lens-lenses-folds-and-traversals README>. .- A video on how to use lenses and how they are constructed is available from youtube: <http://youtu.be/cefnmjtAolY?hd=1>+ An introductory video on the style of code used in this library by Simon Peyton Jones is available from <http://skillsmatter.com/podcast/scala/lenses-compositional-data-access-and-manipulation Skills Matter>. .- Slides can be obtained here: <http://comonad.com/haskell/Lenses-Folds-and-Traversals-NYC.pdf>+ A video on how to use lenses and how they are constructed is available on <http://youtu.be/cefnmjtAolY?hd=1 youtube>. .+ Slides for that second talk can be obtained from <http://comonad.com/haskell/Lenses-Folds-and-Traversals-NYC.pdf comonad.com>.+ . More information on the care and feeding of lenses, including a brief tutorial and motivation- for their types can be found on the lens wiki: <https://github.com/ekmett/lens/wiki>+ for their types can be found on the <https://github.com/ekmett/lens/wiki lens wiki>. .- A small game of @pong@ and other more complex examples that manage their state using lenses can be found in the example folder: <https://github.com/ekmett/lens/blob/master/examples/>+ A small game of @pong@ and other more complex examples that manage their state using lenses can be found in the <https://github.com/ekmett/lens/blob/master/examples/ example folder>. . /Lenses, Folds and Traversals/ .@@ -40,7 +43,7 @@ . <<http://i.imgur.com/4fHw3Fd.png>> .- Local copy (<Hierarchy.png>)+ <Hierarchy.png (Local Copy)> . You can compose any two elements of the hierarchy above using @(.)@ from the @Prelude@, and you can use any element of the hierarchy as any type it linked to above it.@@ -95,11 +98,16 @@ examples/*.lhs examples/bf-examples/*.bf images/*.png+ lens-properties/CHANGELOG.markdown+ lens-properties/LICENSE+ lens-properties/Setup.hs travis/cabal-apt-install travis/config+ HLint.hs AUTHORS.markdown- README.markdown CHANGELOG.markdown+ README.markdown+ SUPPORT.markdown source-repository head type: git@@ -133,6 +141,11 @@ default: False manual: True +-- You can disable the hlint test suite with -f-test-hlint+flag test-hlint+ default: True+ manual: True+ -- You can disable the doctests test suite with -f-test-doctests flag test-doctests default: True@@ -164,23 +177,26 @@ library build-depends:+ aeson >= 0.7 && < 0.8, array >= 0.3.0.2 && < 0.6, base >= 4.3 && < 5, bifunctors >= 4 && < 5, bytestring >= 0.9.1.10 && < 0.11, comonad >= 4 && < 5,- contravariant >= 0.3 && < 2,+ constraints >= 0.3.3 && < 1,+ contravariant >= 0.3 && < 1, containers >= 0.4.0 && < 0.6, distributive >= 0.3 && < 1, filepath >= 1.2.0.0 && < 1.4,- generic-deriving >= 1.4 && < 1.7, ghc-prim, hashable >= 1.1.2.3 && < 1.3,- MonadCatchIO-transformers >= 0.3 && < 0.3.2,+ exceptions >= 0.1.1 && < 1, mtl >= 2.0.1 && < 2.2, parallel >= 3.1.0.1 && < 3.3,+ primitive >= 0.4.0.1 && < 0.6, profunctors >= 4 && < 5, reflection >= 1.1.6 && < 2,+ scientific >= 0.2 && < 0.3, semigroupoids >= 4 && < 5, semigroups >= 0.8.4 && < 1, split >= 0.2 && < 0.3,@@ -190,10 +206,13 @@ transformers >= 0.2 && < 0.4, transformers-compat >= 0.1 && < 1, unordered-containers >= 0.2 && < 0.3,+ utf8-string >= 0.3.7 && < 0.4, vector >= 0.9 && < 0.11,- void >= 0.5 && < 1+ void >= 0.5 && < 1,+ zlib >= 0.5.4 && < 0.6 exposed-modules:+ Codec.Compression.Zlib.Lens Control.Exception.Lens Control.Lens Control.Lens.Action@@ -201,7 +220,9 @@ Control.Lens.Combinators Control.Lens.Cons Control.Lens.Each+ Control.Lens.Empty Control.Lens.Equality+ Control.Lens.Extras Control.Lens.Fold Control.Lens.Getter Control.Lens.Indexed@@ -220,9 +241,10 @@ Control.Lens.Internal.Level Control.Lens.Internal.Magma Control.Lens.Internal.Prism+ Control.Lens.Internal.Reflection Control.Lens.Internal.Review Control.Lens.Internal.Setter- Control.Lens.Internal.Zipper+ Control.Lens.Internal.TH Control.Lens.Internal.Zoom Control.Lens.Iso Control.Lens.Lens@@ -234,17 +256,17 @@ Control.Lens.Reified Control.Lens.Review Control.Lens.Setter- Control.Lens.Simple Control.Lens.TH Control.Lens.Traversal Control.Lens.Tuple Control.Lens.Type Control.Lens.Wrapped- Control.Lens.Zipper Control.Lens.Zoom Control.Monad.Error.Lens+ Control.Monad.Primitive.Lens Control.Parallel.Strategies.Lens Control.Seq.Lens+ Data.Aeson.Lens Data.Array.Lens Data.Bits.Lens Data.ByteString.Lens@@ -257,6 +279,7 @@ Data.IntSet.Lens Data.List.Lens Data.List.Split.Lens+ Data.Map.Lens Data.Sequence.Lens Data.Set.Lens Data.Text.Lens@@ -274,6 +297,9 @@ Language.Haskell.TH.Lens Numeric.Lens + other-modules:+ Control.Lens.Internal.TupleIxedTH+ if flag(safe) cpp-options: -DSAFE=1 @@ -293,9 +319,6 @@ if impl(ghc<7.4) ghc-options: -fno-spec-constr-count - if impl(ghc>=7.2)- cpp-options: -DDEFAULT_SIGNATURES=1- ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10 hs-source-dirs: src @@ -319,8 +342,9 @@ type: exitcode-stdio-1.0 main-is: properties.hs ghc-options: -w -threaded -rtsopts -with-rtsopts=-N- hs-source-dirs: tests-+ hs-source-dirs:+ tests+ lens-properties/src if !flag(test-properties) buildable: False else@@ -384,6 +408,18 @@ if impl(ghc<7.6.1) ghc-options: -Werror +test-suite hlint+ type: exitcode-stdio-1.0+ main-is: hlint.hs+ ghc-options: -w -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: tests++ if !flag(test-hlint)+ buildable: False+ else+ build-depends:+ base,+ hlint >= 1.7 -- Basic benchmarks for the uniplate-style combinators benchmark plated
+ src/Codec/Compression/Zlib/Lens.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module : Codec.Compression.Zlib.Lens+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- @lens@ support for the @zlib@ library+----------------------------------------------------------------------------+module Codec.Compression.Zlib.Lens+ ( -- * High-Level API+ gzipped,+ zlibbed,+ deflated,+ compressed,+ Format,+ gzip,+ zlib,+ deflate,+ -- * Low-Level API+ zlibbed',+ gzipped',+ deflated',+ compressed',+ Params,+ defaultParams,+ levelC,+ methodC,+ windowBitsC,+ windowBitsD,+ memoryLevelC,+ strategyC,+ bufferSizeC,+ bufferSizeD,+ dictionary,+ CompressionLevel,+ defaultCompression,+ noCompression,+ bestSpeed,+ bestCompression,+ compressionLevel,+ Method,+ deflateMethod,+ WindowBits,+ defaultWindowBits,+ windowBits,+ MemoryLevel,+ defaultMemoryLevel,+ minMemoryLevel,+ maxMemoryLevel,+ memoryLevel,+ CompressionStrategy,+ defaultStrategy,+ filteredStrategy,+ huffmanOnlyStrategy+ ) where++import Control.Applicative+import Codec.Compression.Zlib.Internal+import Control.Lens+import qualified Data.ByteString as S (ByteString)+import qualified Data.ByteString.Lazy as L (ByteString)++-- |+-- The 'zlib' compression format.+zlib :: Format+zlib = zlibFormat+{-# INLINE zlib #-}++-- |+-- The 'gzip' compression format.+gzip :: Format+gzip = gzipFormat+{-# INLINE gzip #-}++-- |+-- The 'deflate' compression format.+deflate :: Format+deflate = rawFormat+{-# INLINE deflate #-}++-- |+-- Compresses a 'L.ByteString' using the 'gzip' compression format.+--+-- @+-- 'gzipped' = 'compressed' 'gzip'+-- 'gzipped' = 'gzipped'' 'defaultParams'+-- @+gzipped :: Iso' L.ByteString L.ByteString+gzipped = compressed gzip+{-# INLINE gzipped #-}++-- |+-- Compresses a 'L.ByteString' using the 'zlib' compression format.+--+-- @+-- 'zlibbed' = 'compressed' 'zlib'+-- 'zlibbed' = 'zlibbed\'' 'defaultParams'+-- @+zlibbed :: Iso' L.ByteString L.ByteString+zlibbed = compressed zlib+{-# INLINE zlibbed #-}++-- |+-- Compresses a 'L.ByteString' using the 'deflate' compression format.+--+-- @+-- 'deflated' = 'compressed' 'deflate'+-- 'deflated' = 'deflated'' 'defaultParams'+-- @+deflated :: Iso' L.ByteString L.ByteString+deflated = compressed deflate+{-# INLINE deflated #-}++-- |+-- Compresses a 'L.ByteString' using the given compression format.+--+-- @+-- 'compressed' fmt = 'compressed'' fmt 'defaultParams'+-- @+compressed :: Format -> Iso' L.ByteString L.ByteString+compressed fmt = compressed' fmt defaultParams+{-# INLINE compressed #-}++-- |+-- Compresses a 'L.ByteString' using the 'gzip' compression format and the given advanced parameters.+--+-- @+-- 'gzipped' = 'compressed' 'gzip'+-- 'gzipped' = 'gzipped'' 'defaultParams'+-- @+gzipped' :: Params -> Iso' L.ByteString L.ByteString+gzipped' = compressed' gzip+{-# INLINE gzipped' #-}++-- |+-- Compresses a 'L.ByteString' using the 'zlib' compression format and the given advanced parameters.+--+-- @+-- 'zlibbed' = 'compressed' 'zlib'+-- 'zlibbed' = 'zlibbed'' 'defaultParams'+-- @+zlibbed' :: Params -> Iso' L.ByteString L.ByteString+zlibbed' = compressed' zlib+{-# INLINE zlibbed' #-}++-- |+-- Compresses a 'L.ByteString' using the 'deflate' compression format and the given advanced parameters.+--+-- @+-- 'deflated' = 'compressed' 'deflate'+-- 'deflated' = 'deflated'' 'defaultParams'+-- @+deflated' :: Params -> Iso' L.ByteString L.ByteString+deflated' = compressed' deflate+{-# INLINE deflated' #-}++-- |+-- Compresses a 'L.ByteString' using the given compression format and the given advanced parameters.+compressed' :: Format -> Params -> Iso' L.ByteString L.ByteString+compressed' fmt (Params c d) = iso (compress fmt c) (decompress fmt d)+{-# INLINE compressed' #-}++-- |+-- The advanced parameters needed by 'gzipped'', 'zlibbed'', 'deflated'', and 'compressed''.+--+-- Use 'defaultParams' and the provided 'Lens'es to construct custom 'Params'.+data Params = Params !CompressParams !DecompressParams++-- |+-- The default advanced parameters for compression and decompression.+defaultParams :: Params+defaultParams = Params defaultCompressParams defaultDecompressParams+{-# INLINE defaultParams #-}++-- |+-- The compression level.+levelC :: Lens' Params CompressionLevel+levelC = \ f (Params c d) -> (\l -> Params (c {compressLevel = l}) d) <$> f (compressLevel c)+{-# INLINE levelC #-}++-- |+-- The compression method.+methodC :: Lens' Params Method+methodC = \ f (Params c d) -> (\m -> Params (c {compressMethod = m}) d) <$> f (compressMethod c)+{-# INLINE methodC #-}++-- |+-- The number of bits in the compression window.+windowBitsC :: Lens' Params WindowBits+windowBitsC = \ f (Params c d) -> (\wb -> Params (c {compressWindowBits = wb}) d) <$> f (compressWindowBits c)+{-# INLINE windowBitsC #-}++-- |+-- The number of bits in the decompression window.+windowBitsD :: Lens' Params WindowBits+windowBitsD = \ f (Params c d) -> (\wb -> Params c (d {decompressWindowBits = wb})) <$> f (decompressWindowBits d)+{-# INLINE windowBitsD #-}++-- |+-- The amount of memory allowed for the internal compression state.+memoryLevelC :: Lens' Params MemoryLevel+memoryLevelC = \ f (Params c d) -> (\ml -> Params (c {compressMemoryLevel = ml}) d) <$> f (compressMemoryLevel c)+{-# INLINE memoryLevelC #-}++-- |+-- The compression strategy.+strategyC :: Lens' Params CompressionStrategy+strategyC = \ f (Params c d) -> (\s -> Params (c {compressStrategy = s}) d) <$> f (compressStrategy c)+{-# INLINE strategyC #-}++-- |+-- The initial buffer size during compression.+bufferSizeC :: Lens' Params Int+bufferSizeC = \ f (Params c d) -> (\bs -> Params (c {compressBufferSize = bs}) d) <$> f (compressBufferSize c)+{-# INLINE bufferSizeC #-}++-- |+-- The initial buffer size during decompression.+bufferSizeD :: Lens' Params Int+bufferSizeD = \ f (Params c d) -> (\bs -> Params c (d {decompressBufferSize = bs})) <$> f (decompressBufferSize d)+{-# INLINE bufferSizeD #-}++-- |+-- 'Just' the custom (de)compression dictionary to use, or 'Nothing' to not use a custom dictionary.+dictionary :: Lens' Params (Maybe S.ByteString)+dictionary = \f (Params c d) -> (\mbs -> Params (c {compressDictionary = mbs}) (d {decompressDictionary = mbs})) <$> f (compressDictionary c <|> decompressDictionary d)+{-# INLINE dictionary #-}
src/Control/Exception/Lens.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE NoMonomorphismRestriction #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-}@@ -17,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -30,7 +28,7 @@ -- be found in "System.IO.Error.Lens". -- -- The combinators in this module have been generalized to work with--- 'MonadCatchIO' instead of just 'IO'. This enables them to be used+-- 'MonadCatch' instead of just 'IO'. This enables them to be used -- more easily in 'Monad' transformer stacks. ---------------------------------------------------------------------------- module Control.Exception.Lens@@ -39,11 +37,13 @@ catching, catching_ , handling, handling_ -- * Trying- , trying+ , trying, trying_ -- * Throwing , throwing , throwingM , throwingTo+ -- * Mapping+ , mappedException, mappedException' -- * Exceptions , exception -- * Exception Handlers@@ -100,16 +100,16 @@ import Control.Applicative import Control.Monad import Control.Monad.IO.Class-import Control.Monad.CatchIO as CatchIO hiding (try, tryJust)+import Control.Monad.Catch as Catch import Control.Exception as Exception hiding (try, tryJust, catchJust) import Control.Lens import Control.Lens.Internal.Exception import Data.Monoid import GHC.Conc (ThreadId) import Prelude- ( asTypeOf, const, either, flip, id, maybe, undefined- , ($), (.)- , Maybe(..), Either(..), Functor(..), String, IO+ ( const, either, flip, id+ , (.)+ , Maybe(..), Either(..), String ) #ifdef HLINT@@ -145,14 +145,14 @@ -- "caught" -- -- @--- 'catching' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatchIO' m => 'Lens'' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatchIO' m => 'Traversal'' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatchIO' m => 'Iso'' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r -- @-catching :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r+catching :: MonadCatch m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} @@ -165,24 +165,17 @@ -- "caught" -- -- @--- 'catching_' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatchIO' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatchIO' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatchIO' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r -- @-catching_ :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m r -> m r+catching_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} --- | A helper function to provide conditional catch behavior.-catchJust :: (MonadCatchIO m, Exception e) => (e -> Maybe t) -> m a -> (t -> m a) -> m a-catchJust f m k = CatchIO.catch m $ \ e -> case f e of- Nothing -> liftIO (throwIO e)- Just x -> k x-{-# INLINE catchJust #-}- ------------------------------------------------------------------------------ -- Handling ------------------------------------------------------------------------------@@ -194,14 +187,14 @@ -- "caught" -- -- @--- 'handling' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatchIO' m => 'Lens'' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatchIO' m => 'Traversal'' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatchIO' m => 'Iso'' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r -- @-handling :: MonadCatchIO m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r+handling :: MonadCatch m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} @@ -212,14 +205,14 @@ -- "caught" -- -- @--- 'handling_' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatchIO' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatchIO' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatchIO' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r -- @-handling_ :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m r -> m r+handling_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} @@ -232,29 +225,30 @@ -- 'Exception' does not match the predicate, it is re-thrown. -- -- @--- 'trying' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatchIO' m => 'Lens'' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatchIO' m => 'Traversal'' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatchIO' m => 'Iso'' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m ('Either' a r) -- @-trying :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m (Either a r)+trying :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Either a r) trying l = tryJust (preview l)---- | A helper version of 'Control.Exception.try' that doesn't needlessly require 'Functor'.-try :: (MonadCatchIO m, Exception e) => m a -> m (Either e a)-try a = CatchIO.catch (liftM Right a) (return . Left)+{-# INLINE trying #-} --- | A helper version of 'Control.Exception.tryJust' that doesn't needlessly require 'Functor'.-tryJust :: (MonadCatchIO m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a)-tryJust p a = do- r <- try a- case r of- Right v -> return (Right v)- Left e -> case p e of- Nothing -> CatchIO.throw e `asTypeOf` return (Left undefined)- Just b -> return (Left b)+-- | A version of 'trying' that discards the specific exception thrown.+--+-- @+-- 'trying_' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m (Maybe r)+-- @+trying_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Maybe r)+trying_ l m = preview _Right `liftM` trying l m+{-# INLINE trying_ #-} ------------------------------------------------------------------------------ -- Throwing@@ -276,7 +270,7 @@ {-# INLINE throwing #-} -- | A variant of 'throwing' that can only be used within the 'IO' 'Monad'--- (or any other 'MonadCatchIO' instance) to throw an 'Exception' described +-- (or any other 'MonadCatch' instance) to throw an 'Exception' described -- by a 'Prism'. -- -- Although 'throwingM' has a type that is a specialization of the type of@@ -289,7 +283,7 @@ -- -- The first example will cause the 'Exception' @e@ to be raised, whereas the -- second one won't. In fact, 'throwingM' will only cause an 'Exception' to--- be raised when it is used within the 'MonadCatchIO' instance. The 'throwingM'+-- be raised when it is used within the 'MonadCatch' instance. The 'throwingM' -- variant should be used in preference to 'throwing' to raise an 'Exception' -- within the 'Monad' because it guarantees ordering with respect to other -- monadic operations, whereas 'throwing' does not.@@ -299,11 +293,11 @@ -- @ -- -- @--- 'throwingM' :: 'MonadIO' m => 'Prism'' 'SomeException' t -> t -> m r--- 'throwingM' :: 'MonadIO' m => 'Iso'' 'SomeException' t -> t -> m r+-- 'throwingM' :: 'MonadCatch' m => 'Prism'' 'SomeException' t -> t -> m r+-- 'throwingM' :: 'MonadCatch' m => 'Iso'' 'SomeException' t -> t -> m r -- @-throwingM :: MonadIO m => AReview s SomeException a b -> b -> m r-throwingM l = reviews l (liftIO . throwIO)+throwingM :: MonadCatch m => AReview s SomeException a b -> b -> m r+throwingM l = reviews l throwM {-# INLINE throwingM #-} -- | 'throwingTo' raises an 'Exception' specified by a 'Prism' in the target thread.@@ -321,6 +315,39 @@ {-# INLINE throwingTo #-} ----------------------------------------------------------------------------+-- Mapping+----------------------------------------------------------------------------++-- | This 'Setter' can be used to purely map over the 'Exception's an+-- arbitrary expression might throw; it is a variant of 'mapException' in+-- the same way that 'mapped' is a variant of 'fmap'.+--+-- > 'mapException' ≡ 'over' 'mappedException'+--+-- This view that every Haskell expression can be regarded as carrying a bag+-- of 'Exception's is detailed in “A Semantics for Imprecise Exceptions” by+-- Peyton Jones & al. at PLDI ’99.+--+-- The following maps failed assertions to arithmetic overflow:+--+-- >>> handling _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & mappedException %~ \ (AssertionFailed _) -> Overflow+-- "caught"+mappedException :: (Exception e, Exception e') => Setter s s e e'+mappedException = sets mapException+{-# INLINE mappedException #-}++-- | This is a type restricted version of 'mappedException', which avoids+-- the type ambiguity in the input 'Exception' when using 'set'.+--+-- The following maps any exception to arithmetic overflow:+--+-- >>> handling _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & mappedException' .~ Overflow+-- "caught"+mappedException' :: Exception e' => Setter s s SomeException e'+mappedException' = mappedException+{-# INLINE mappedException' #-}++---------------------------------------------------------------------------- -- IOException ---------------------------------------------------------------------------- @@ -330,24 +357,24 @@ -- -- Due to their richer structure relative to other exceptions, these have -- a more carefully overloaded signature.-class AsIOException p f t where+class AsIOException t where -- | Unfortunately the name 'ioException' is taken by @base@ for -- throwing IOExceptions. -- -- @- -- '_IOException' :: 'Equality'' 'IOException' 'IOException'+ -- '_IOException' :: 'Prism'' 'IOException' 'IOException' -- '_IOException' :: 'Prism'' 'SomeException' 'IOException' -- @ -- -- Many combinators for working with an 'IOException' are available -- in "System.IO.Error.Lens".- _IOException :: Overloaded' p f t IOException+ _IOException :: Prism' t IOException -instance AsIOException p f IOException where+instance AsIOException IOException where _IOException = id {-# INLINE _IOException #-} -instance (Choice p, Applicative f) => AsIOException p f SomeException where+instance AsIOException SomeException where _IOException = exception {-# INLINE _IOException #-} @@ -356,16 +383,16 @@ ---------------------------------------------------------------------------- -- | Arithmetic exceptions.-class AsArithException p f t where- -- '_ArithException' :: 'Equality'' 'ArithException' 'ArithException'- -- '_ArithException' :: 'Prism'' 'SomeException' 'ArithException'- _ArithException :: Overloaded' p f t ArithException+class AsArithException t where+ -- '_ArithException' :: 'Prism'' 'ArithException' 'ArithException'+ -- '_ArithException' :: 'Prism'' 'SomeException' 'ArithException'+ _ArithException :: Prism' t ArithException -instance AsArithException p f ArithException where+instance AsArithException ArithException where _ArithException = id {-# INLINE _ArithException #-} -instance (Choice p, Applicative f) => AsArithException p f SomeException where+instance AsArithException SomeException where _ArithException = exception {-# INLINE _ArithException #-} @@ -379,7 +406,7 @@ -- '_Overflow' :: 'Prism'' 'ArithException' 'ArithException' -- '_Overflow' :: 'Prism'' 'SomeException' 'ArithException' -- @-_Overflow :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_Overflow :: AsArithException t => Prism' t () _Overflow = _ArithException . dimap seta (either id id) . right' . rmap (Overflow <$) where seta Overflow = Right () seta t = Left (pure t)@@ -395,7 +422,7 @@ -- '_Underflow' :: 'Prism'' 'ArithException' 'ArithException' -- '_Underflow' :: 'Prism'' 'SomeException' 'ArithException' -- @-_Underflow :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_Underflow :: AsArithException t => Prism' t () _Underflow = _ArithException . dimap seta (either id id) . right' . rmap (Underflow <$) where seta Underflow = Right () seta t = Left (pure t)@@ -411,7 +438,7 @@ -- '_LossOfPrecision' :: 'Prism'' 'ArithException' 'ArithException' -- '_LossOfPrecision' :: 'Prism'' 'SomeException' 'ArithException' -- @-_LossOfPrecision :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_LossOfPrecision :: AsArithException t => Prism' t () _LossOfPrecision = _ArithException . dimap seta (either id id) . right' . rmap (LossOfPrecision <$) where seta LossOfPrecision = Right () seta t = Left (pure t)@@ -427,13 +454,13 @@ -- '_DivideByZero' :: 'Prism'' 'ArithException' 'ArithException' -- '_DivideByZero' :: 'Prism'' 'SomeException' 'ArithException' -- @-_DivideByZero :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_DivideByZero :: AsArithException t => Prism' t () _DivideByZero = _ArithException . dimap seta (either id id) . right' . rmap (DivideByZero <$) where seta DivideByZero = Right () seta t = Left (pure t) {-# INLINE _DivideByZero #-} --- | Handle exceptional _Denormalized floating point.+-- | Handle exceptional _Denormalized floating pure. -- -- @ -- '_Denormal' ≡ '_ArithException' '.' '_Denormal'@@ -443,7 +470,7 @@ -- '_Denormal' :: 'Prism'' 'ArithException' 'ArithException' -- '_Denormal' :: 'Prism'' 'SomeException' 'ArithException' -- @-_Denormal :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_Denormal :: AsArithException t => Prism' t () _Denormal = _ArithException . dimap seta (either id id) . right' . rmap (Denormal <$) where seta Denormal = Right () seta t = Left (pure t)@@ -462,7 +489,7 @@ -- '_RatioZeroDenominator' :: 'Prism'' 'ArithException' 'ArithException' -- '_RatioZeroDenominator' :: 'Prism'' 'SomeException' 'ArithException' -- @-_RatioZeroDenominator :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_RatioZeroDenominator :: AsArithException t => Prism' t () _RatioZeroDenominator = _ArithException . dimap seta (either id id) . right' . rmap (RatioZeroDenominator <$) where seta RatioZeroDenominator = Right () seta t = Left (pure t)@@ -475,20 +502,20 @@ ---------------------------------------------------------------------------- -- | Exceptions generated by array operations.-class AsArrayException p f t where+class AsArrayException t where -- | Extract information about an 'ArrayException'. -- -- @- -- '_ArrayException' :: 'Equality'' 'ArrayException' 'ArrayException'- -- '_ArrayException' :: 'Prism'' 'SomeException' 'ArrayException'+ -- '_ArrayException' :: 'Prism'' 'ArrayException' 'ArrayException'+ -- '_ArrayException' :: 'Prism'' 'SomeException' 'ArrayException' -- @- _ArrayException :: Overloaded' p f t ArrayException+ _ArrayException :: Prism' t ArrayException -instance AsArrayException p f ArrayException where+instance AsArrayException ArrayException where _ArrayException = id {-# INLINE _ArrayException #-} -instance (Choice p, Applicative f) => AsArrayException p f SomeException where+instance AsArrayException SomeException where _ArrayException = exception {-# INLINE _ArrayException #-} @@ -502,7 +529,7 @@ -- '_IndexOutOfBounds' :: 'Prism'' 'ArrayException' 'String' -- '_IndexOutOfBounds' :: 'Prism'' 'SomeException' 'String' -- @-_IndexOutOfBounds :: (AsArrayException p f t, Choice p, Applicative f) => Overloaded' p f t String+_IndexOutOfBounds :: AsArrayException t => Prism' t String _IndexOutOfBounds = _ArrayException . dimap seta (either id id) . right' . rmap (fmap IndexOutOfBounds) where seta (IndexOutOfBounds r) = Right r seta t = Left (pure t)@@ -518,7 +545,7 @@ -- '_UndefinedElement' :: 'Prism'' 'ArrayException' 'String' -- '_UndefinedElement' :: 'Prism'' 'SomeException' 'String' -- @-_UndefinedElement :: (AsArrayException p f t, Choice p, Applicative f) => Overloaded' p f t String+_UndefinedElement :: AsArrayException t => Prism' t String _UndefinedElement = _ArrayException . dimap seta (either id id) . right' . rmap (fmap UndefinedElement) where seta (UndefinedElement r) = Right r seta t = Left (pure t)@@ -529,24 +556,24 @@ ---------------------------------------------------------------------------- -- | 'assert' was applied to 'Prelude.False'.-class AsAssertionFailed p f t where+class AsAssertionFailed t where -- | This 'Exception' contains provides information about what assertion failed in the 'String'. -- -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("<interactive>" `isInfixOf` xs) ) $ assert False (return "uncaught") -- "caught" -- -- @- -- '_AssertionFailed' :: 'Iso'' 'AssertionFailed' 'String'+ -- '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String' -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' -- @- _AssertionFailed :: Overloaded' p f t String+ _AssertionFailed :: Prism' t String -instance (Profunctor p, Functor f) => AsAssertionFailed p f AssertionFailed where- _AssertionFailed = unwrapping AssertionFailed+instance AsAssertionFailed AssertionFailed where+ _AssertionFailed = _Wrapping AssertionFailed {-# INLINE _AssertionFailed #-} -instance (Choice p, Applicative f) => AsAssertionFailed p f SomeException where- _AssertionFailed = exception.unwrapping AssertionFailed+instance AsAssertionFailed SomeException where+ _AssertionFailed = exception._Wrapping AssertionFailed {-# INLINE _AssertionFailed #-} ----------------------------------------------------------------------------@@ -554,20 +581,20 @@ ---------------------------------------------------------------------------- -- | Asynchronous exceptions.-class AsAsyncException p f t where+class AsAsyncException t where -- | There are several types of 'AsyncException'. -- -- @ -- '_AsyncException' :: 'Equality'' 'AsyncException' 'AsyncException' -- '_AsyncException' :: 'Prism'' 'SomeException' 'AsyncException' -- @- _AsyncException :: Overloaded' p f t AsyncException+ _AsyncException :: Prism' t AsyncException -instance AsAsyncException p f AsyncException where+instance AsAsyncException AsyncException where _AsyncException = id {-# INLINE _AsyncException #-} -instance (Choice p, Applicative f) => AsAsyncException p f SomeException where+instance AsAsyncException SomeException where _AsyncException = exception {-# INLINE _AsyncException #-} @@ -579,7 +606,7 @@ -- '_StackOverflow' :: 'Prism'' 'AsyncException' () -- '_StackOverflow' :: 'Prism'' 'SomeException' () -- @-_StackOverflow :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_StackOverflow :: AsAsyncException t => Prism' t () _StackOverflow = _AsyncException . dimap seta (either id id) . right' . rmap (StackOverflow <$) where seta StackOverflow = Right () seta t = Left (pure t)@@ -598,10 +625,10 @@ -- '_HeapOverflow' :: 'Prism'' 'AsyncException' () -- '_HeapOverflow' :: 'Prism'' 'SomeException' () -- @-_HeapOverflow :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_HeapOverflow :: AsAsyncException t => Prism' t () _HeapOverflow = _AsyncException . dimap seta (either id id) . right' . rmap (HeapOverflow <$) where seta HeapOverflow = Right ()- seta t = Left (pure t)+ seta t = Left (pure t) {-# INLINE _HeapOverflow #-} -- | This 'Exception' is raised by another thread calling@@ -612,10 +639,10 @@ -- '_ThreadKilled' :: 'Prism'' 'AsyncException' () -- '_ThreadKilled' :: 'Prism'' 'SomeException' () -- @-_ThreadKilled :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_ThreadKilled :: AsAsyncException t => Prism' t () _ThreadKilled = _AsyncException . dimap seta (either id id) . right' . rmap (ThreadKilled <$) where seta ThreadKilled = Right ()- seta t = Left (pure t)+ seta t = Left (pure t) {-# INLINE _ThreadKilled #-} -- | This 'Exception' is raised by default in the main thread of the program when@@ -626,7 +653,7 @@ -- '_UserInterrupt' :: 'Prism'' 'AsyncException' () -- '_UserInterrupt' :: 'Prism'' 'SomeException' () -- @-_UserInterrupt :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t ()+_UserInterrupt :: AsAsyncException t => Prism' t () _UserInterrupt = _AsyncException . dimap seta (either id id) . right' . rmap (UserInterrupt <$) where seta UserInterrupt = Right () seta t = Left (pure t)@@ -639,20 +666,20 @@ -- | Thrown when the runtime system detects that the computation is guaranteed -- not to terminate. Note that there is no guarantee that the runtime system -- will notice whether any given computation is guaranteed to terminate or not.-class (Profunctor p, Functor f) => AsNonTermination p f t where+class AsNonTermination t where -- | There is no additional information carried in a 'NonTermination' 'Exception'. -- -- @- -- '_NonTermination' :: 'Iso'' 'NonTermination' ()+ -- '_NonTermination' :: 'Prism'' 'NonTermination' () -- '_NonTermination' :: 'Prism'' 'SomeException' () -- @- _NonTermination :: Overloaded' p f t ()+ _NonTermination :: Prism' t () -instance (Profunctor p, Functor f) => AsNonTermination p f NonTermination where+instance AsNonTermination NonTermination where _NonTermination = trivial NonTermination {-# INLINE _NonTermination #-} -instance (Choice p, Applicative f) => AsNonTermination p f SomeException where+instance AsNonTermination SomeException where _NonTermination = exception.trivial NonTermination {-# INLINE _NonTermination #-} @@ -662,20 +689,20 @@ -- | Thrown when the program attempts to call atomically, from the -- 'Control.Monad.STM' package, inside another call to atomically.-class (Profunctor p, Functor f) => AsNestedAtomically p f t where+class AsNestedAtomically t where -- | There is no additional information carried in a 'NestedAtomically' 'Exception'. -- -- @- -- '_NestedAtomically' :: 'Iso'' 'NestedAtomically' ()+ -- '_NestedAtomically' :: 'Prism'' 'NestedAtomically' () -- '_NestedAtomically' :: 'Prism'' 'SomeException' () -- @- _NestedAtomically :: Overloaded' p f t ()+ _NestedAtomically :: Prism' t () -instance (Profunctor p, Functor f) => AsNestedAtomically p f NestedAtomically where+instance AsNestedAtomically NestedAtomically where _NestedAtomically = trivial NestedAtomically {-# INLINE _NestedAtomically #-} -instance (Choice p, Applicative f) => AsNestedAtomically p f SomeException where+instance AsNestedAtomically SomeException where _NestedAtomically = exception.trivial NestedAtomically {-# INLINE _NestedAtomically #-} @@ -686,20 +713,20 @@ -- | The thread is blocked on an 'Control.Concurrent.MVar.MVar', but there -- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't -- ever continue.-class (Profunctor p, Functor f) => AsBlockedIndefinitelyOnMVar p f t where+class AsBlockedIndefinitelyOnMVar t where -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'. -- -- @- -- '_BlockedIndefinitelyOnMVar' :: 'Iso'' 'BlockedIndefinitelyOnMVar' ()+ -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'BlockedIndefinitelyOnMVar' () -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'SomeException' () -- @- _BlockedIndefinitelyOnMVar :: Overloaded' p f t ()+ _BlockedIndefinitelyOnMVar :: Prism' t () -instance (Profunctor p, Functor f) => AsBlockedIndefinitelyOnMVar p f BlockedIndefinitelyOnMVar where+instance AsBlockedIndefinitelyOnMVar BlockedIndefinitelyOnMVar where _BlockedIndefinitelyOnMVar = trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} -instance (Choice p, Applicative f) => AsBlockedIndefinitelyOnMVar p f SomeException where+instance AsBlockedIndefinitelyOnMVar SomeException where _BlockedIndefinitelyOnMVar = exception.trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} @@ -710,20 +737,20 @@ -- | The thread is waiting to retry an 'Control.Monad.STM.STM' transaction, -- but there are no other references to any TVars involved, so it can't ever -- continue.-class (Profunctor p, Functor f) => AsBlockedIndefinitelyOnSTM p f t where+class AsBlockedIndefinitelyOnSTM t where -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'. -- -- @- -- '_BlockedIndefinitelyOnSTM' :: 'Iso'' 'BlockedIndefinitelyOnSTM' ()+ -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'BlockedIndefinitelyOnSTM' () -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'SomeException' () -- @- _BlockedIndefinitelyOnSTM :: Overloaded' p f t ()+ _BlockedIndefinitelyOnSTM :: Prism' t () -instance (Profunctor p, Functor f) => AsBlockedIndefinitelyOnSTM p f BlockedIndefinitelyOnSTM where+instance AsBlockedIndefinitelyOnSTM BlockedIndefinitelyOnSTM where _BlockedIndefinitelyOnSTM = trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} -instance (Choice p, Applicative f) => AsBlockedIndefinitelyOnSTM p f SomeException where+instance AsBlockedIndefinitelyOnSTM SomeException where _BlockedIndefinitelyOnSTM = exception.trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} @@ -733,20 +760,20 @@ -- | There are no runnable threads, so the program is deadlocked. The -- 'Deadlock' 'Exception' is raised in the main thread only.-class (Profunctor p, Functor f) => AsDeadlock p f t where+class AsDeadlock t where -- | There is no information carried in a 'Deadlock' 'Exception'. -- -- @- -- '_Deadlock' :: 'Iso'' 'Deadlock' ()+ -- '_Deadlock' :: 'Prism'' 'Deadlock' () -- '_Deadlock' :: 'Prism'' 'SomeException' () -- @- _Deadlock :: Overloaded' p f t ()+ _Deadlock :: Prism' t () -instance (Profunctor p, Functor f) => AsDeadlock p f Deadlock where+instance AsDeadlock Deadlock where _Deadlock = trivial Deadlock {-# INLINE _Deadlock #-} -instance (Choice p, Applicative f) => AsDeadlock p f SomeException where+instance AsDeadlock SomeException where _Deadlock = exception.trivial Deadlock {-# INLINE _Deadlock #-} @@ -756,21 +783,21 @@ -- | A class method without a definition (neither a default definition, -- nor a definition in the appropriate instance) was called.-class (Profunctor p, Functor f) => AsNoMethodError p f t where+class AsNoMethodError t where -- | Extract a description of the missing method. -- -- @- -- '_NoMethodError' :: 'Iso'' 'NoMethodError' 'String'+ -- '_NoMethodError' :: 'Prism'' 'NoMethodError' 'String' -- '_NoMethodError' :: 'Prism'' 'SomeException' 'String' -- @- _NoMethodError :: Overloaded' p f t String+ _NoMethodError :: Prism' t String -instance (Profunctor p, Functor f) => AsNoMethodError p f NoMethodError where- _NoMethodError = unwrapping NoMethodError+instance AsNoMethodError NoMethodError where+ _NoMethodError = _Wrapping NoMethodError {-# INLINE _NoMethodError #-} -instance (Choice p, Applicative f) => AsNoMethodError p f SomeException where- _NoMethodError = exception.unwrapping NoMethodError+instance AsNoMethodError SomeException where+ _NoMethodError = exception._Wrapping NoMethodError {-# INLINE _NoMethodError #-} ----------------------------------------------------------------------------@@ -778,21 +805,21 @@ ---------------------------------------------------------------------------- -- | A pattern match failed.-class (Profunctor p, Functor f) => AsPatternMatchFail p f t where+class AsPatternMatchFail t where -- | Information about the source location of the pattern. -- -- @- -- '_PatternMatchFail' :: 'Iso'' 'PatternMatchFail' 'String'+ -- '_PatternMatchFail' :: 'Prism'' 'PatternMatchFail' 'String' -- '_PatternMatchFail' :: 'Prism'' 'SomeException' 'String' -- @- _PatternMatchFail :: Overloaded' p f t String+ _PatternMatchFail :: Prism' t String -instance (Profunctor p, Functor f) => AsPatternMatchFail p f PatternMatchFail where- _PatternMatchFail = unwrapping PatternMatchFail+instance AsPatternMatchFail PatternMatchFail where+ _PatternMatchFail = _Wrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} -instance (Choice p, Applicative f) => AsPatternMatchFail p f SomeException where- _PatternMatchFail = exception.unwrapping PatternMatchFail+instance AsPatternMatchFail SomeException where+ _PatternMatchFail = exception._Wrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} ----------------------------------------------------------------------------@@ -800,22 +827,22 @@ ---------------------------------------------------------------------------- -- | An uninitialised record field was used.-class (Profunctor p, Functor f) => AsRecConError p f t where+class AsRecConError t where -- | Information about the source location where the record was -- constructed. -- -- @- -- '_RecConError' :: 'Iso'' 'RecConError' 'String'+ -- '_RecConError' :: 'Prism'' 'RecConError' 'String' -- '_RecConError' :: 'Prism'' 'SomeException' 'String' -- @- _RecConError :: Overloaded' p f t String+ _RecConError :: Prism' t String -instance (Profunctor p, Functor f) => AsRecConError p f RecConError where- _RecConError = unwrapping RecConError+instance AsRecConError RecConError where+ _RecConError = _Wrapping RecConError {-# INLINE _RecConError #-} -instance (Choice p, Applicative f) => AsRecConError p f SomeException where- _RecConError = exception.unwrapping RecConError+instance AsRecConError SomeException where+ _RecConError = exception._Wrapping RecConError {-# INLINE _RecConError #-} ----------------------------------------------------------------------------@@ -825,16 +852,16 @@ -- | A record selector was applied to a constructor without the appropriate -- field. This can only happen with a datatype with multiple constructors, -- where some fields are in one constructor but not another.-class (Profunctor p, Functor f) => AsRecSelError p f t where+class AsRecSelError t where -- | Information about the source location where the record selection occurred.- _RecSelError :: Overloaded' p f t String+ _RecSelError :: Prism' t String -instance (Profunctor p, Functor f) => AsRecSelError p f RecSelError where- _RecSelError = unwrapping RecSelError+instance AsRecSelError RecSelError where+ _RecSelError = _Wrapping RecSelError {-# INLINE _RecSelError #-} -instance (Choice p, Applicative f) => AsRecSelError p f SomeException where- _RecSelError = exception.unwrapping RecSelError+instance AsRecSelError SomeException where+ _RecSelError = exception._Wrapping RecSelError {-# INLINE _RecSelError #-} ----------------------------------------------------------------------------@@ -844,16 +871,16 @@ -- | A record update was performed on a constructor without the -- appropriate field. This can only happen with a datatype with multiple -- constructors, where some fields are in one constructor but not another.-class (Profunctor p, Functor f) => AsRecUpdError p f t where+class AsRecUpdError t where -- | Information about the source location where the record was updated.- _RecUpdError :: Overloaded' p f t String+ _RecUpdError :: Prism' t String -instance (Profunctor p, Functor f) => AsRecUpdError p f RecUpdError where- _RecUpdError = unwrapping RecUpdError+instance AsRecUpdError RecUpdError where+ _RecUpdError = _Wrapping RecUpdError {-# INLINE _RecUpdError #-} -instance (Choice p, Applicative f) => AsRecUpdError p f SomeException where- _RecUpdError = exception.unwrapping RecUpdError+instance AsRecUpdError SomeException where+ _RecUpdError = exception._Wrapping RecUpdError {-# INLINE _RecUpdError #-} ----------------------------------------------------------------------------@@ -861,21 +888,21 @@ ---------------------------------------------------------------------------- -- | This is thrown when the user calls 'Prelude.error'.-class (Profunctor p, Functor f) => AsErrorCall p f t where+class AsErrorCall t where -- | Retrieve the argument given to 'Prelude.error'. -- -- 'ErrorCall' is isomorphic to a 'String'. -- -- >>> catching _ErrorCall (error "touch down!") return -- "touch down!"- _ErrorCall :: Overloaded' p f t String+ _ErrorCall :: Prism' t String -instance (Profunctor p, Functor f) => AsErrorCall p f ErrorCall where- _ErrorCall = unwrapping ErrorCall+instance AsErrorCall ErrorCall where+ _ErrorCall = _Wrapping ErrorCall {-# INLINE _ErrorCall #-} -instance (Choice p, Applicative f) => AsErrorCall p f SomeException where- _ErrorCall = exception.unwrapping ErrorCall+instance AsErrorCall SomeException where+ _ErrorCall = exception._Wrapping ErrorCall {-# INLINE _ErrorCall #-} ------------------------------------------------------------------------------@@ -884,20 +911,20 @@ -- | This 'Exception' is thrown by @lens@ when the user somehow manages to rethrow -- an internal 'HandlingException'.-class (Profunctor p, Functor f) => AsHandlingException p f t where+class AsHandlingException t where -- | There is no information carried in a 'HandlingException'. -- -- @- -- '_HandlingException' :: 'Iso'' 'HandlingException' ()+ -- '_HandlingException' :: 'Prism'' 'HandlingException' () -- '_HandlingException' :: 'Prism'' 'SomeException' () -- @- _HandlingException :: Overloaded' p f t ()+ _HandlingException :: Prism' t () -instance (Profunctor p, Functor f) => AsHandlingException p f HandlingException where+instance AsHandlingException HandlingException where _HandlingException = trivial HandlingException {-# INLINE _HandlingException #-} -instance (Choice p, Applicative f) => AsHandlingException p f SomeException where+instance AsHandlingException SomeException where _HandlingException = exception.trivial HandlingException {-# INLINE _HandlingException #-}
src/Control/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -42,9 +42,9 @@ module Control.Lens ( module Control.Lens.Action , module Control.Lens.At- , module Control.Lens.Combinators , module Control.Lens.Cons , module Control.Lens.Each+ , module Control.Lens.Empty , module Control.Lens.Equality , module Control.Lens.Fold , module Control.Lens.Getter@@ -58,7 +58,6 @@ , module Control.Lens.Reified , module Control.Lens.Review , module Control.Lens.Setter- , module Control.Lens.Simple #ifndef DISABLE_TEMPLATE_HASKELL , module Control.Lens.TH #endif@@ -66,15 +65,14 @@ , module Control.Lens.Tuple , module Control.Lens.Type , module Control.Lens.Wrapped- , module Control.Lens.Zipper , module Control.Lens.Zoom ) where import Control.Lens.Action import Control.Lens.At-import Control.Lens.Combinators import Control.Lens.Cons import Control.Lens.Each+import Control.Lens.Empty import Control.Lens.Equality import Control.Lens.Fold import Control.Lens.Getter@@ -88,7 +86,6 @@ import Control.Lens.Reified import Control.Lens.Review import Control.Lens.Setter-import Control.Lens.Simple #ifndef DISABLE_TEMPLATE_HASKELL import Control.Lens.TH #endif@@ -96,7 +93,6 @@ import Control.Lens.Tuple import Control.Lens.Type import Control.Lens.Wrapped-import Control.Lens.Zipper import Control.Lens.Zoom #ifdef HLINT
src/Control/Lens/Action.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Action--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -61,21 +61,21 @@ infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!? -- | Used to evaluate an 'Action'.-type Acting m r s t a b = LensLike (Effect m r) s t a b+type Acting m r s a = LensLike (Effect m r) s s a a -- | Perform an 'Action'. -- -- @ -- 'perform' ≡ 'flip' ('^!') -- @-perform :: Monad m => Acting m a s t a b -> s -> m a+perform :: Monad m => Acting m a s a -> s -> m a perform l = getEffect #. l (Effect #. return) {-# INLINE perform #-} -- | Perform an 'Action' and modify the result. -- -- @--- 'performs' :: 'Monad' m => 'Acting' m e s t a b -> (a -> e) -> s -> m e+-- 'performs' :: 'Monad' m => 'Acting' m e s a -> (a -> e) -> s -> m e -- @ performs :: (Profunctor p, Monad m) => Over p (Effect m e) s t a b -> p a e -> s -> m e performs l f = getEffect #. l (rmap (Effect #. return) f)@@ -86,7 +86,7 @@ -- >>> ["hello","world"]^!folded.act putStrLn -- hello -- world-(^!) :: Monad m => s -> Acting m a s t a b -> m a+(^!) :: Monad m => s -> Acting m a s a -> m a a ^! l = getEffect (l (Effect #. return) a) {-# INLINE (^!) #-} @@ -94,7 +94,7 @@ -- -- >>> ["ab","cd","ef"]^!!folded.acts -- ["ace","acf","ade","adf","bce","bcf","bde","bdf"]-(^!!) :: Monad m => s -> Acting m [a] s t a b -> m [a]+(^!!) :: Monad m => s -> Acting m [a] s a -> m [a] a ^!! l = getEffect (l (Effect #. return . return) a) {-# INLINE (^!!) #-} @@ -106,7 +106,7 @@ -- Just (Just 1) -- >>> [Just 1, Nothing]^!?folded.acts -- Nothing-(^!?) :: Monad m => s -> Acting m (Leftmost a) s t a b -> m (Maybe a)+(^!?) :: Monad m => s -> Acting m (Leftmost a) s a -> m (Maybe a) a ^!? l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) a {-# INLINE (^!?) #-} @@ -133,12 +133,12 @@ -- -- >>> (1,"hello")^!_2.acts.to succ -- "ifmmp"-acts :: Action m (m a) a+acts :: IndexPreservingAction m (m a) a acts = act id {-# INLINE acts #-} -- | Apply a 'Monad' transformer to an 'Action'.-liftAct :: (MonadTrans trans, Monad m) => Acting m a s t a b -> Action (trans m) s a+liftAct :: (MonadTrans trans, Monad m) => Acting m a s a -> IndexPreservingAction (trans m) s a liftAct l = act (lift . perform l) {-# INLINE liftAct #-} @@ -147,36 +147,36 @@ ---------------------------------------------------------------------------- -- | Used to evaluate an 'IndexedAction'.-type IndexedActing i m r s t a b = Over (Indexed i) (Effect m r) s t a b+type IndexedActing i m r s a = Over (Indexed i) (Effect m r) s s a a -- | Perform an 'IndexedAction'. -- -- @ -- 'iperform' ≡ 'flip' ('^@!') -- @-iperform :: Monad m => IndexedActing i m (i, a) s t a b -> s -> m (i, a)+iperform :: Monad m => IndexedActing i m (i, a) s a -> s -> m (i, a) iperform l = getEffect #. l (Indexed $ \i a -> Effect (return (i, a))) {-# INLINE iperform #-} -- | Perform an 'IndexedAction' and modify the result.-iperforms :: Monad m => IndexedActing i m e s t a b -> (i -> a -> e) -> s -> m e+iperforms :: Monad m => IndexedActing i m e s a -> (i -> a -> e) -> s -> m e iperforms l = performs l .# Indexed {-# INLINE iperforms #-} -- | Perform an 'IndexedAction'.-(^@!) :: Monad m => s -> IndexedActing i m (i, a) s t a b -> m (i, a)+(^@!) :: Monad m => s -> IndexedActing i m (i, a) s a -> m (i, a) s ^@! l = getEffect (l (Indexed $ \i a -> Effect (return (i, a))) s) {-# INLINE (^@!) #-} -- | Obtain a list of all of the results of an 'IndexedMonadicFold'.-(^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s t a b -> m [(i, a)]+(^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s a -> m [(i, a)] s ^@!! l = getEffect (l (Indexed $ \i a -> Effect (return [(i, a)])) s) {-# INLINE (^@!!) #-} -- | Perform an 'IndexedMonadicFold' and collect the 'Leftmost' result. -- -- /Note:/ this still causes all effects for all elements.-(^@!?) :: Monad m => s -> IndexedActing i m (Leftmost (i, a)) s t a b -> m (Maybe (i, a))+(^@!?) :: Monad m => s -> IndexedActing i m (Leftmost (i, a)) s a -> m (Maybe (i, a)) a ^@!? l = liftM getLeftmost .# getEffect $ l (Indexed $ \i -> Effect #. return . LLeaf . (,) i) a {-# INLINE (^@!?) #-}
src/Control/Lens/At.hs view
@@ -2,15 +2,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}--#ifdef DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures #-}-#endif+{-# LANGUAGE TypeOperators #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-}@@ -22,7 +21,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.At--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -34,44 +33,37 @@ -- * At At(at), sans -- * Ixed+ , Index , IxValue , Ixed(ix)- , ixAt, ixEach+ , ixAt -- * Contains , Contains(..)- , containsIx, containsAt, containsLength, containsN, containsTest, containsLookup- -- * Deprecated- , _at- , resultAt ) where import Control.Applicative-import Control.Lens.Combinators-import Control.Lens.Each-import Control.Lens.Fold-import Control.Lens.Getter-import Control.Lens.Indexed as Lens+import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.Type-import Control.Lens.Traversal+import Control.Lens.Internal.TupleIxedTH (makeAllTupleIxed) import Data.Array.IArray as Array import Data.Array.Unboxed import Data.ByteString as StrictB import Data.ByteString.Lazy as LazyB import Data.Complex-import Data.Functor.Identity import Data.Hashable import Data.HashMap.Lazy as HashMap import Data.HashSet as HashSet+import Data.Int import Data.IntMap as IntMap import Data.IntSet as IntSet+import Data.List.NonEmpty as NonEmpty import Data.Map as Map-import Data.Maybe-import Data.Monoid import Data.Set as Set import Data.Sequence as Seq import Data.Text as StrictT import Data.Text.Lazy as LazyT+import Data.Traversable import Data.Tree import Data.Vector as Vector hiding (indexed) import Data.Vector.Primitive as Prim@@ -79,6 +71,40 @@ import Data.Vector.Unboxed as Unboxed import Data.Word +type family Index (s :: *) :: *+type instance Index (e -> a) = e+type instance Index IntSet = Int+type instance Index (Set a) = a+type instance Index (HashSet a) = a+type instance Index [a] = Int+type instance Index (NonEmpty a) = Int+type instance Index (Seq a) = Int+type instance Index (a,b) = Int+type instance Index (a,b,c) = Int+type instance Index (a,b,c,d) = Int+type instance Index (a,b,c,d,e) = Int+type instance Index (a,b,c,d,e,f) = Int+type instance Index (a,b,c,d,e,f,g) = Int+type instance Index (a,b,c,d,e,f,g,h) = Int+type instance Index (a,b,c,d,e,f,g,h,i) = Int+type instance Index (IntMap a) = Int+type instance Index (Map k a) = k+type instance Index (HashMap k a) = k+type instance Index (Array i e) = i+type instance Index (UArray i e) = i+type instance Index (Vector.Vector a) = Int+type instance Index (Prim.Vector a) = Int+type instance Index (Storable.Vector a) = Int+type instance Index (Unboxed.Vector a) = Int+type instance Index (Complex a) = Int+type instance Index (Identity a) = ()+type instance Index (Maybe a) = ()+type instance Index (Tree a) = [Int]+type instance Index StrictT.Text = Int+type instance Index LazyT.Text = Int64+type instance Index StrictB.ByteString = Int+type instance Index LazyB.ByteString = Int64+ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens@@ -87,16 +113,10 @@ -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g --- | Deprecated aliases for 'ix'.-_at, resultAt :: Ixed f m => Index m -> IndexedLensLike' (Index m) f m (IxValue m)-_at = ix-resultAt = ix-{-# DEPRECATED _at, resultAt "use 'ix'. This function will be removed after GHC 7.8 is released." #-}- -- | -- This class provides a simple 'IndexedFold' (or 'IndexedTraversal') that lets you view (and modify) -- information about whether or not a container contains a given 'Index'.-class Functor f => Contains f m where+class Contains m where -- | -- >>> IntSet.fromList [1,2,3,4] ^. contains 3 -- True@@ -106,188 +126,33 @@ -- -- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False -- fromList [1,2,4]- contains :: Index m -> IndexedLensLike' (Index m) f m Bool-#ifdef DEFAULT_SIGNATURES- default contains :: (Contravariant f, Functor f, At m) => Index m -> IndexedLensLike' (Index m) f m Bool- contains = containsAt-#endif---- | A definition of 'contains' for types with an 'Ix' instance.-containsIx :: (Contravariant f, Functor f, Ixed (Accessor Any) m) => Index m -> IndexedLensLike' (Index m) f m Bool-containsIx i f = coerce . Lens.indexed f i . has (ix i)-{-# INLINE containsIx #-}---- | A definition of 'ix' for types with an 'At' instance. This is the default--- if you don't specify a definition for 'contains' and you are on GHC >= 7.0.2-containsAt :: (Contravariant f, Functor f, At m) => Index m -> IndexedLensLike' (Index m) f m Bool-containsAt i f = coerce . Lens.indexed f i . views (at i) isJust-{-# INLINE containsAt #-}---- | Construct a 'contains' check based on some notion of 'Prelude.length' for the container.-containsLength :: forall i s. (Ord i, Num i) => (s -> i) -> i -> IndexedGetter i s Bool-containsLength sn = \ i pafb s -> coerce $ Lens.indexed pafb (i :: i) (0 <= i && i < sn s)-{-# INLINE containsLength #-}---- | Construct a 'contains' check for a fixed number of elements.-containsN :: Int -> Int -> IndexedGetter Int s Bool-containsN n = \ i pafb _ -> coerce $ Lens.indexed pafb (i :: Int) (0 <= i && i < n)-{-# INLINE containsN #-}---- | Construct a 'contains' check that uses an arbitrary test.-containsTest :: forall i s. (i -> s -> Bool) -> i -> IndexedGetter i s Bool-containsTest isb = \i pafb s -> coerce $ Lens.indexed pafb (i :: i) (isb i s)-{-# INLINE containsTest #-}---- | Construct a 'contains' check that uses an arbitrary 'Map.lookup' function.-containsLookup :: forall i s a. (i -> s -> Maybe a) -> i -> IndexedGetter i s Bool-containsLookup isb = \i pafb s -> coerce $ Lens.indexed pafb (i :: i) (isJust (isb i s))-{-# INLINE containsLookup #-}--instance (Functor f, Contravariant f) => Contains f (e -> a) where- contains i f _ = coerce (Lens.indexed f i True)- {-# INLINE contains #-}+ contains :: Index m -> Lens' m Bool -instance Functor f => Contains f IntSet where- contains k f s = Lens.indexed f k (IntSet.member k s) <&> \b ->+instance Contains IntSet where+ contains k f s = f (IntSet.member k s) <&> \b -> if b then IntSet.insert k s else IntSet.delete k s {-# INLINE contains #-} -instance (Functor f, Ord a) => Contains f (Set a) where- contains k f s = Lens.indexed f k (Set.member k s) <&> \b ->+instance Ord a => Contains (Set a) where+ contains k f s = f (Set.member k s) <&> \b -> if b then Set.insert k s else Set.delete k s {-# INLINE contains #-} -instance (Functor f, Eq a, Hashable a) => Contains f (HashSet a) where- contains k f s = Lens.indexed f k (HashSet.member k s) <&> \b ->+instance (Eq a, Hashable a) => Contains (HashSet a) where+ contains k f s = f (HashSet.member k s) <&> \b -> if b then HashSet.insert k s else HashSet.delete k s {-# INLINE contains #-} -instance (Contravariant f, Functor f) => Contains f [a] where- contains = containsLength Prelude.length- {-# INLINE contains #-}--instance (Contravariant f, Functor f) => Contains f (Seq a) where- contains = containsLength Seq.length- {-# INLINE contains #-}--#if MIN_VERSION_base(4,4,0)-instance (Contravariant f, Functor f) => Contains f (Complex a) where- contains = containsN 2- {-# INLINE contains #-}-#else-instance (Contravariant f, Functor f, RealFloat a) => Contains f (Complex a) where- contains = containsN 2- {-# INLINE contains #-}-#endif--instance (Contravariant f, Functor f) => Contains f (Tree a) where- contains xs0 pafb = coerce . Lens.indexed pafb xs0 . go xs0 where- go [] (Node _ _) = True- go (i:is) (Node _ as) | i < 0 = False- | otherwise = goto i is as- goto 0 is (a:_) = go is a- goto _ _ [] = False- goto n is (_:as) = (goto $! n - 1) is as- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (Identity a) where- contains () f _ = coerce (Lens.indexed f () True)- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b) where- contains = containsN 2- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c) where- contains = containsN 3- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c,d) where- contains = containsN 4- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e) where- contains = containsN 5- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f) where- contains = containsN 6- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f,g) where- contains = containsN 7- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f,g,h) where- contains = containsN 8- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f,g,h,i) where- contains = containsN 9- {-# INLINE contains #-}--instance (Contravariant k, Functor k) => Contains k (IntMap a) where- contains = containsLookup IntMap.lookup- {-# INLINE contains #-}--instance (Contravariant f, Functor f, Ord k) => Contains f (Map k a) where- contains = containsLookup Map.lookup- {-# INLINE contains #-}--instance (Contravariant f, Functor f, Eq k, Hashable k) => Contains f (HashMap k a) where- contains = containsLookup HashMap.lookup- {-# INLINE contains #-}--instance (Contravariant f, Functor f, Ix i) => Contains f (Array i e) where- contains = containsTest $ \i s -> inRange (bounds s) i- {-# INLINE contains #-}--instance (Contravariant f, Functor f, IArray UArray e, Ix i) => Contains f (UArray i e) where- contains = containsTest $ \i s -> inRange (bounds s) i- {-# INLINE contains #-}--instance (Contravariant f, Functor f) => Contains f (Vector.Vector a) where- contains = containsLength Vector.length- {-# INLINE contains #-}--instance (Contravariant f, Functor f, Prim a) => Contains f (Prim.Vector a) where- contains = containsLength Prim.length- {-# INLINE contains #-}--instance (Contravariant f, Functor f, Storable a) => Contains f (Storable.Vector a) where- contains = containsLength Storable.length- {-# INLINE contains #-}--instance (Contravariant f, Functor f, Unbox a) => Contains f (Unboxed.Vector a) where- contains = containsLength Unboxed.length- {-# INLINE contains #-}--instance (Contravariant f, Functor f) => Contains f StrictT.Text where- contains = containsTest $ \i s -> StrictT.compareLength s i == GT- {-# INLINE contains #-}--instance (Contravariant f, Functor f) => Contains f LazyT.Text where- contains = containsTest $ \i s -> LazyT.compareLength s i == GT- {-# INLINE contains #-}--instance (Contravariant f, Functor f) => Contains f StrictB.ByteString where- contains = containsLength StrictB.length- {-# INLINE contains #-}--instance (Contravariant f, Functor f) => Contains f LazyB.ByteString where- contains = containsTest $ \i s -> not (LazyB.null (LazyB.drop i s))- {-# INLINE contains #-}- -- | This provides a common notion of a value at an index that is shared by both 'Ixed' and 'At'. type family IxValue (m :: *) :: * --- | This simple 'IndexedTraversal' lets you 'traverse' the value at a given+-- | This simple 'AffineTraversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'.-class Functor f => Ixed f m where- -- | This simple 'IndexedTraversal' lets you 'traverse' the value at a given+class Ixed m where+ -- | This simple 'AffineTraversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. --- -- /NB:/ Setting the value of this 'Traversal' will only set the value in the+ -- /NB:/ Setting the value of this 'AffineTraversal' will only set the value in the -- 'Lens' if it is already present. -- -- If you want to be able to insert /missing/ values, you want 'at'.@@ -303,42 +168,51 @@ -- -- >>> Seq.fromList [] ^? ix 2 -- Nothing- ix :: Index m -> IndexedLensLike' (Index m) f m (IxValue m)+ ix :: Index m -> Traversal' m (IxValue m) #ifdef DEFAULT_SIGNATURES- default ix :: (Applicative f, At m) => Index m -> IndexedLensLike' (Index m) f m (IxValue m)+ default ix :: (Applicative f, At m) => Index m -> LensLike' f m (IxValue m) ix = ixAt {-# INLINE ix #-} #endif -- | A definition of 'ix' for types with an 'At' instance. This is the default -- if you don't specify a definition for 'ix'.-ixAt :: (Applicative f, At m) => Index m -> IndexedLensLike' (Index m) f m (IxValue m)-ixAt i = at i <. traverse+ixAt :: At m => Index m -> Traversal' m (IxValue m)+ixAt i = at i . traverse {-# INLINE ixAt #-} --- | A definition of 'ix' for types with an 'Each' instance.-ixEach :: (Applicative f, Eq (Index m), Each f m m (IxValue m) (IxValue m)) => Index m -> IndexedLensLike' (Index m) f m (IxValue m)-ixEach i = each . Lens.index i-{-# INLINE ixEach #-}+type instance IxValue (Maybe a) = a+instance Ixed (Maybe a) where+ ix () f (Just a) = Just <$> f a+ ix () _ Nothing = pure Nothing+ {-# INLINE ix #-} type instance IxValue [a] = a-instance Applicative f => Ixed f [a] where+instance Ixed [a] where ix k f xs0 | k < 0 = pure xs0 | otherwise = go xs0 k where go [] _ = pure []- go (a:as) 0 = Lens.indexed f k a <&> (:as)+ go (a:as) 0 = f a <&> (:as) go (a:as) i = (a:) <$> (go as $! i - 1) {-# INLINE ix #-} +type instance IxValue (NonEmpty a) = a+instance Ixed (NonEmpty a) where+ ix k f xs0 | k < 0 = pure xs0+ | otherwise = go xs0 k where+ go (a:|as) 0 = f a <&> (:|as)+ go (a:|as) i = (a:|) <$> ix (i - 1) f as+ {-# INLINE ix #-}+ type instance IxValue (Identity a) = a-instance Functor f => Ixed f (Identity a) where- ix () f (Identity a) = Identity <$> Lens.indexed f () a+instance Ixed (Identity a) where+ ix () f (Identity a) = Identity <$> f a {-# INLINE ix #-} type instance IxValue (Tree a) = a-instance Applicative f => Ixed f (Tree a) where+instance Ixed (Tree a) where ix xs0 f = go xs0 where- go [] (Node a as) = Lens.indexed f xs0 a <&> \a' -> Node a' as+ go [] (Node a as) = f a <&> \a' -> Node a' as go (i:is) t@(Node a as) | i < 0 = pure t | otherwise = Node a <$> goto is as i goto is (a:as) 0 = go is a <&> (:as)@@ -347,42 +221,63 @@ {-# INLINE ix #-} type instance IxValue (Seq a) = a-instance Applicative f => Ixed f (Seq a) where+instance Ixed (Seq a) where ix i f m- | 0 <= i && i < Seq.length m = Lens.indexed f i (Seq.index m i) <&> \a -> Seq.update i a m+ | 0 <= i && i < Seq.length m = f (Seq.index m i) <&> \a -> Seq.update i a m | otherwise = pure m {-# INLINE ix #-} type instance IxValue (IntMap a) = a-instance Applicative f => Ixed f (IntMap a) where+instance Ixed (IntMap a) where ix k f m = case IntMap.lookup k m of- Just v -> Lens.indexed f k v <&> \v' -> IntMap.insert k v' m+ Just v -> f v <&> \v' -> IntMap.insert k v' m Nothing -> pure m {-# INLINE ix #-} type instance IxValue (Map k a) = a-instance (Applicative f, Ord k) => Ixed f (Map k a) where+instance Ord k => Ixed (Map k a) where ix k f m = case Map.lookup k m of- Just v -> Lens.indexed f k v <&> \v' -> Map.insert k v' m+ Just v -> f v <&> \v' -> Map.insert k v' m Nothing -> pure m {-# INLINE ix #-} type instance IxValue (HashMap k a) = a-instance (Applicative f, Eq k, Hashable k) => Ixed f (HashMap k a) where+instance (Eq k, Hashable k) => Ixed (HashMap k a) where ix k f m = case HashMap.lookup k m of- Just v -> Lens.indexed f k v <&> \v' -> HashMap.insert k v' m+ Just v -> f v <&> \v' -> HashMap.insert k v' m Nothing -> pure m {-# INLINE ix #-} +type instance IxValue (Set k) = ()+instance Ord k => Ixed (Set k) where+ ix k f m = if Set.member k m+ then f () <&> \() -> Set.insert k m+ else pure m+ {-# INLINE ix #-}++type instance IxValue IntSet = ()+instance Ixed IntSet where+ ix k f m = if IntSet.member k m+ then f () <&> \() -> IntSet.insert k m+ else pure m+ {-# INLINE ix #-}++type instance IxValue (HashSet k) = ()+instance (Eq k, Hashable k) => Ixed (HashSet k) where+ ix k f m = if HashSet.member k m+ then f () <&> \() -> HashSet.insert k m+ else pure m+ {-# INLINE ix #-}+ type instance IxValue (Array i e) = e -- | -- @ -- arr '!' i ≡ arr 'Control.Lens.Getter.^.' 'ix' i -- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr -- @-instance (Applicative f, Ix i) => Ixed f (Array i e) where+instance Ix i => Ixed (Array i e) where ix i f arr- | inRange (bounds arr) i = Lens.indexed f i (arr Array.! i) <&> \e -> arr Array.// [(i,e)]+ | inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)] | otherwise = pure arr {-# INLINE ix #-} @@ -392,129 +287,74 @@ -- arr '!' i ≡ arr 'Control.Lens.Getter.^.' 'ix' i -- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr -- @-instance (Applicative f, IArray UArray e, Ix i) => Ixed f (UArray i e) where+instance (IArray UArray e, Ix i) => Ixed (UArray i e) where ix i f arr- | inRange (bounds arr) i = Lens.indexed f i (arr Array.! i) <&> \e -> arr Array.// [(i,e)]+ | inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)] | otherwise = pure arr {-# INLINE ix #-} type instance IxValue (Vector.Vector a) = a-instance Applicative f => Ixed f (Vector.Vector a) where+instance Ixed (Vector.Vector a) where ix i f v- | 0 <= i && i < Vector.length v = Lens.indexed f i (v Vector.! i) <&> \a -> v Vector.// [(i, a)]+ | 0 <= i && i < Vector.length v = f (v Vector.! i) <&> \a -> v Vector.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue (Prim.Vector a) = a-instance (Applicative f, Prim a) => Ixed f (Prim.Vector a) where+instance Prim a => Ixed (Prim.Vector a) where ix i f v- | 0 <= i && i < Prim.length v = Lens.indexed f i (v Prim.! i) <&> \a -> v Prim.// [(i, a)]+ | 0 <= i && i < Prim.length v = f (v Prim.! i) <&> \a -> v Prim.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue (Storable.Vector a) = a-instance (Applicative f, Storable a) => Ixed f (Storable.Vector a) where+instance Storable a => Ixed (Storable.Vector a) where ix i f v- | 0 <= i && i < Storable.length v = Lens.indexed f i (v Storable.! i) <&> \a -> v Storable.// [(i, a)]+ | 0 <= i && i < Storable.length v = f (v Storable.! i) <&> \a -> v Storable.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue (Unboxed.Vector a) = a-instance (Applicative f, Unbox a) => Ixed f (Unboxed.Vector a) where+instance Unbox a => Ixed (Unboxed.Vector a) where ix i f v- | 0 <= i && i < Unboxed.length v = Lens.indexed f i (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]+ | 0 <= i && i < Unboxed.length v = f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue StrictT.Text = Char-instance Applicative f => Ixed f StrictT.Text where+instance Ixed StrictT.Text where ix e f s = case StrictT.splitAt e s of (l, mr) -> case StrictT.uncons mr of Nothing -> pure s- Just (c, xs) -> Lens.indexed f e c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs]+ Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyT.Text = Char-instance Applicative f => Ixed f LazyT.Text where+instance Ixed LazyT.Text where ix e f s = case LazyT.splitAt e s of (l, mr) -> case LazyT.uncons mr of Nothing -> pure s- Just (c, xs) -> Lens.indexed f e c <&> \d -> LazyT.append l (LazyT.cons d xs)+ Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs) {-# INLINE ix #-} type instance IxValue StrictB.ByteString = Word8-instance Applicative f => Ixed f StrictB.ByteString where+instance Ixed StrictB.ByteString where ix e f s = case StrictB.splitAt e s of (l, mr) -> case StrictB.uncons mr of Nothing -> pure s- Just (c, xs) -> Lens.indexed f e c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs]+ Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyB.ByteString = Word8-instance Applicative f => Ixed f LazyB.ByteString where+instance Ixed LazyB.ByteString where -- TODO: we could be lazier, returning each chunk as it is passed ix e f s = case LazyB.splitAt e s of (l, mr) -> case LazyB.uncons mr of Nothing -> pure s- Just (c, xs) -> Lens.indexed f e c <&> \d -> LazyB.append l (LazyB.cons d xs)+ Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs) {-# INLINE ix #-} -type instance IxValue (k -> a) = a-instance (Functor f, Eq k) => Ixed f (k -> a) where- ix e g f = Lens.indexed g e (f e) <&> \a' e' -> if e == e' then a' else f e'- {-# INLINE ix #-} -#if MIN_VERSION_base(4,4,0)-type instance IxValue (Complex a) = a-instance Applicative f => Ixed f (Complex a) where- ix = ixEach- {-# INLINE ix #-}-#else-instance (Applicative f, RealFloat a) => Ixed f (Complex a) where- ix = ixEach- {-# INLINE ix #-}-#endif--type instance IxValue (a,a) = a-instance (Applicative f, a ~ b) => Ixed f (a,b) where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a) = a-instance (Applicative f, a ~ b, b ~ c) => Ixed f (a,b,c) where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a,a) = a-instance (Applicative f, a ~ b, b ~ c, c ~ d) => Ixed f (a,b,c,d) where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a,a,a) = a-instance (Applicative f, a ~ b, b ~ c, c ~ d, d ~ e) => Ixed f (a,b,c,d,e) where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a,a,a,a) = a-instance (Applicative f, a ~ b, b ~ c, c ~ d, d ~ e, e ~ f') => Ixed f (a,b,c,d,e,f') where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a,a,a,a,a) = a-instance (Applicative f, a ~ b, b ~ c, c ~ d, d ~ e, e ~ f', f' ~ g) => Ixed f (a,b,c,d,e,f',g) where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a,a,a,a,a,a) = a-instance (Applicative f, a ~ b, b ~ c, c ~ d, d ~ e, e ~ f', f' ~ g, g ~ h) => Ixed f (a,b,c,d,e,f',g,h) where- ix = ixEach- {-# INLINE ix #-}--type instance IxValue (a,a,a,a,a,a,a,a,a) = a-instance (Applicative f, a ~ b, b ~ c, c ~ d, d ~ e, e ~ f', f' ~ g, g ~ h, h ~ i) => Ixed f (a,b,c,d,e,f',g,h,i) where- ix = ixEach- {-# INLINE ix #-}- -- | '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.@@ -522,9 +362,9 @@ -- An instance of 'At' should satisfy: -- -- @--- 'ix' k ≡ 'at' k '<.' 'traverse'+-- 'ix' k ≡ 'at' k '.' 'traverse' -- @-class At m where+class Ixed m => At m where -- | -- >>> Map.fromList [(1,"world")] ^.at 1 -- Just "world"@@ -534,29 +374,56 @@ -- -- /Note:/ 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where -- you cannot satisfy the 'Lens' laws.- at :: Index m -> IndexedLens' (Index m) m (Maybe (IxValue m))+ at :: Index m -> Lens' m (Maybe (IxValue m)) sans :: At m => Index m -> m -> m sans k m = m & at k .~ Nothing {-# INLINE sans #-} +instance At (Maybe a) where+ at () f = f+ {-# INLINE at #-}+ instance At (IntMap a) where- at k f m = Lens.indexed f k mv <&> \r -> case r of+ at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (IntMap.delete k m)) mv Just v' -> IntMap.insert k v' m where mv = IntMap.lookup k m {-# INLINE at #-} instance Ord k => At (Map k a) where- at k f m = Lens.indexed f k mv <&> \r -> case r of+ at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (Map.delete k m)) mv Just v' -> Map.insert k v' m where mv = Map.lookup k m {-# INLINE at #-} instance (Eq k, Hashable k) => At (HashMap k a) where- at k f m = Lens.indexed f k mv <&> \r -> case r of+ at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (HashMap.delete k m)) mv Just v' -> HashMap.insert k v' m where mv = HashMap.lookup k m {-# INLINE at #-}++instance At IntSet where+ at k f m = f mv <&> \r -> case r of+ Nothing -> maybe m (const (IntSet.delete k m)) mv+ Just () -> IntSet.insert k m+ where mv = if IntSet.member k m then Just () else Nothing+ {-# INLINE at #-}++instance Ord k => At (Set k) where+ at k f m = f mv <&> \r -> case r of+ Nothing -> maybe m (const (Set.delete k m)) mv+ Just () -> Set.insert k m+ where mv = if Set.member k m then Just () else Nothing+ {-# INLINE at #-}++instance (Eq k, Hashable k) => At (HashSet k) where+ at k f m = f mv <&> \r -> case r of+ Nothing -> maybe m (const (HashSet.delete k m)) mv+ Just () -> HashSet.insert k m+ where mv = if HashSet.member k m then Just () else Nothing+ {-# INLINE at #-}++makeAllTupleIxed
src/Control/Lens/Combinators.hs view
@@ -1,73 +1,146 @@+ -------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Combinators--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2013-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable+-- Stability : experimental+-- Portability : non-portable ----- These are general purpose combinators that provide utility for non-lens code--------------------------------------------------------------------------------+-- This lets the subset of users who vociferously disagree about the full+-- scope and set of operators that should be exported from lens to not have+-- to look at any operator with which they disagree.+--+-- > import Control.Lens.Combinators+-------------------------------------------------------------------------------- module Control.Lens.Combinators- ( (&)+ ( module Control.Lens+ ) where++import Control.Lens hiding+ ( -- output from scripts/operators+ (^!)+ , (^!!)+ , (^!?)+ , (^@!)+ , (^@!!)+ , (^@!?)+ , (<|)+ , (|>)+ , (^..)+ , (^?)+ , (^?!)+ , (^@..)+ , (^@?)+ , (^@?!)+ , (^.)+ , (^@.)+ , (<.)+ , (.>)+ , (<.>)+ , (%%~)+ , (%%=)+ , (&) , (<&>) , (??)- ) where--import Data.Functor ((<$>))---- $setup--- >>> import Control.Lens--- >>> import Control.Monad.State--- >>> import Debug.SimpleReflect.Expr--- >>> import Debug.SimpleReflect.Vars as Vars hiding (f)--- >>> :set -XNoOverloadedStrings--- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f--infixl 1 &, <&>, ??---- | Passes the result of the left side to the function on the right side (forward pipe operator).------ This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed--- 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 'Control.Lens.Lens.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 (&) #-}---- | Infix flipped 'fmap'.------ @--- ('<&>') = 'flip' 'fmap'--- @-(<&>) :: Functor f => f a -> (a -> b) -> f b-as <&> f = f <$> as-{-# INLINE (<&>) #-}---- | This is convenient to 'flip' argument order of composite functions.------ >>> over _2 ?? ("hello","world") $ length--- ("hello",5)------ >>> over ?? length ?? ("hello","world") $ _2--- ("hello",5)-(??) :: Functor f => f (a -> b) -> a -> f b-fab ?? a = fmap ($ a) fab-{-# INLINE (??) #-}+ , (<%~)+ , (<+~)+ , (<-~)+ , (<*~)+ , (<//~)+ , (<^~)+ , (<^^~)+ , (<**~)+ , (<||~)+ , (<&&~)+ , (<<%~)+ , (<<.~)+ , (<<+~)+ , (<<-~)+ , (<<*~)+ , (<<//~)+ , (<<^~)+ , (<<^^~)+ , (<<**~)+ , (<<||~)+ , (<<&&~)+ , (<<<>~)+ , (<%=)+ , (<+=)+ , (<-=)+ , (<*=)+ , (<//=)+ , (<^=)+ , (<^^=)+ , (<**=)+ , (<||=)+ , (<&&=)+ , (<<%=)+ , (<<.=)+ , (<<+=)+ , (<<-=)+ , (<<*=)+ , (<<//=)+ , (<<^=)+ , (<<^^=)+ , (<<**=)+ , (<<||=)+ , (<<&&=)+ , (<<<>=)+ , (<<~)+ , (<<>~)+ , (<<>=)+ , (<%@~)+ , (<<%@~)+ , (%%@~)+ , (%%@=)+ , (<%@=)+ , (<<%@=)+ , (^#)+ , ( #~ )+ , ( #%~ )+ , ( #%%~ )+ , ( #= )+ , ( #%= )+ , (<#%~)+ , (<#%=)+ , ( #%%= )+ , (<#~)+ , (<#=)+ , (...)+ , ( # )+ , (%~)+ , (.~)+ , (?~)+ , (<.~)+ , (<?~)+ , (+~)+ , (*~)+ , (-~)+ , (//~)+ , (^~)+ , (^^~)+ , (**~)+ , (||~)+ , (&&~)+ , (.=)+ , (%=)+ , (?=)+ , (+=)+ , (-=)+ , (*=)+ , (//=)+ , (^=)+ , (^^=)+ , (**=)+ , (&&=)+ , (||=)+ , (<~)+ , (<.=)+ , (<?=)+ , (<>~)+ , (<>=)+ , (%@~)+ , (%@=)+ )
src/Control/Lens/Cons.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Cons--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -32,20 +32,15 @@ , _init, _last ) where -import Control.Applicative import Control.Lens.Equality (simply) import Control.Lens.Fold-import Control.Lens.Internal.Getter-import Control.Lens.Internal.Review import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Tuple import Control.Lens.Type import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB-import Data.Functor.Identity import Data.Monoid-import Data.Profunctor import qualified Data.Sequence as Seq import Data.Sequence hiding ((<|), (|>)) import qualified Data.Text as StrictT@@ -60,6 +55,8 @@ import qualified Data.Vector.Unboxed as Unbox import Data.Word +{-# ANN module "HLint: ignore Eta reduce" #-}+ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens@@ -77,8 +74,8 @@ -- | This class provides a way to attach or detach elements on the left -- side of a structure in a flexible manner.-class (Profunctor p, Functor f) => Cons p f s t a b | s -> a, t -> b, s b -> t, t a -> s where- -- | Most of the time this is a 'Prism'.+class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where+ -- | -- -- @ -- '_Cons' :: 'Prism' [a] [b] (a, [a]) (b, [b])@@ -88,57 +85,58 @@ -- '_Cons' :: 'Prism'' 'StrictT.Text' ('Char', 'StrictT.Text') -- '_Cons' :: 'Prism'' 'StrictB.ByteString' ('Word8', 'StrictB.ByteString') -- @- --- -- However, by including @p@ and @f@ in the class you can write instances that only permit 'uncons'- -- or which only permit 'cons', or where '_head' and '_tail' are lenses and not traversals.- _Cons :: Overloaded p f s t (a,s) (b,t)+ _Cons :: Prism s t (a,s) (b,t) -instance (Choice p, Applicative f) => Cons p f [a] [b] a b where+instance Cons [a] [b] a b where _Cons = prism (uncurry (:)) $ \ aas -> case aas of (a:as) -> Right (a, as) [] -> Left [] {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Cons p f (Seq a) (Seq b) a b where+instance Cons (Seq a) (Seq b) a b where _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of a :< as -> Right (a, as) EmptyL -> Left mempty {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Cons p f StrictB.ByteString StrictB.ByteString Word8 Word8 where+instance Cons StrictB.ByteString StrictB.ByteString Word8 Word8 where _Cons = prism' (uncurry StrictB.cons) StrictB.uncons+ {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Cons p f LazyB.ByteString LazyB.ByteString Word8 Word8 where+instance Cons LazyB.ByteString LazyB.ByteString Word8 Word8 where _Cons = prism' (uncurry LazyB.cons) LazyB.uncons+ {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Cons p f StrictT.Text StrictT.Text Char Char where+instance Cons StrictT.Text StrictT.Text Char Char where _Cons = prism' (uncurry StrictT.cons) StrictT.uncons+ {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Cons p f LazyT.Text LazyT.Text Char Char where+instance Cons LazyT.Text LazyT.Text Char Char where _Cons = prism' (uncurry LazyT.cons) LazyT.uncons+ {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Cons p f (Vector a) (Vector b) a b where+instance Cons (Vector a) (Vector b) a b where _Cons = prism (uncurry Vector.cons) $ \v -> if Vector.null v then Left Vector.empty else Right (Vector.unsafeHead v, Vector.unsafeTail v) {-# INLINE _Cons #-} -instance (Choice p, Applicative f, Prim a, Prim b) => Cons p f (Prim.Vector a) (Prim.Vector b) a b where+instance (Prim a, Prim b) => Cons (Prim.Vector a) (Prim.Vector b) a b where _Cons = prism (uncurry Prim.cons) $ \v -> if Prim.null v then Left Prim.empty else Right (Prim.unsafeHead v, Prim.unsafeTail v) {-# INLINE _Cons #-} -instance (Choice p, Applicative f, Storable a, Storable b) => Cons p f (Storable.Vector a) (Storable.Vector b) a b where+instance (Storable a, Storable b) => Cons (Storable.Vector a) (Storable.Vector b) a b where _Cons = prism (uncurry Storable.cons) $ \v -> if Storable.null v then Left Storable.empty else Right (Storable.unsafeHead v, Storable.unsafeTail v) {-# INLINE _Cons #-} -instance (Choice p, Applicative f, Unbox a, Unbox b) => Cons p f (Unbox.Vector a) (Unbox.Vector b) a b where+instance (Unbox a, Unbox b) => Cons (Unbox.Vector a) (Unbox.Vector b) a b where _Cons = prism (uncurry Unbox.cons) $ \v -> if Unbox.null v then Left Unbox.empty@@ -148,17 +146,47 @@ -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'.-(<|) :: Cons Reviewed Identity s s a a => a -> s -> s+--+-- >>> a <| []+-- [a]+--+-- >>> a <| [b, c]+-- [a,b,c]+--+-- >>> a <| Seq.fromList []+-- fromList [a]+--+-- >>> a <| Seq.fromList [b, c]+-- fromList [a,b,c]+(<|) :: Cons s s a a => a -> s -> s (<|) = curry (simply review _Cons) {-# INLINE (<|) #-} -- | 'cons' an element onto a container.-cons :: Cons Reviewed Identity s s a a => a -> s -> s+--+-- >>> cons a []+-- [a]+--+-- >>> cons a [b, c]+-- [a,b,c]+--+-- >>> cons a (Seq.fromList [])+-- fromList [a]+--+-- >>> cons a (Seq.fromList [b, c])+-- fromList [a,b,c]+cons :: Cons s s a a => a -> s -> s cons = curry (simply review _Cons) {-# INLINE cons #-} -- | Attempt to extract the left-most element from a container, and a version of the container without that element.-uncons :: Cons (->) (Accessor (First (a, s))) s s a a => s -> Maybe (a, s)+--+-- >>> uncons []+-- Nothing+--+-- >>> uncons [a, b, c]+-- Just (a,[b,c])+uncons :: Cons s s a a => s -> Maybe (a, s) uncons = simply preview _Cons {-# INLINE uncons #-} @@ -212,7 +240,7 @@ -- '_head' :: 'Traversal'' ('Seq' a) a -- '_head' :: 'Traversal'' ('Vector' a) a -- @-_head :: Cons (->) f s s a a => LensLike' f s a+_head :: Cons s s a a => Traversal' s a _head = _Cons._1 {-# INLINE _head #-} @@ -261,7 +289,7 @@ -- '_tail' :: 'Traversal'' ('Seq' a) ('Seq' a) -- '_tail' :: 'Traversal'' ('Vector' a) ('Vector' a) -- @-_tail :: Cons (->) f s s a a => LensLike' f s s+_tail :: Cons s s a a => Traversal' s s _tail = _Cons._2 {-# INLINE _tail #-} @@ -271,8 +299,8 @@ -- | This class provides a way to attach or detach elements on the right -- side of a structure in a flexible manner.-class (Profunctor p, Functor f) => Snoc p f s t a b | s -> a, t -> b, s b -> t, t a -> s where- -- | Most of the time this is a 'Prism'.+class Snoc s t a b | s -> a, t -> b, s b -> t, t a -> s where+ -- | -- -- @ -- '_Snoc' :: 'Prism' [a] [b] ([a], a) ([b], b)@@ -282,66 +310,63 @@ -- '_Snoc' :: 'Prism'' 'StrictT.Text' ('StrictT.Text', 'Char') -- '_Snoc' :: 'Prism'' 'StrictB.ByteString' ('StrictB.ByteString', 'Word8') -- @- --- -- However, by including @p@ and @f@ in the class you can write instances that only permit 'unsnoc'- -- or which only permit 'snoc' or where '_init' and '_last' are lenses and not traversals.- _Snoc :: Overloaded p f s t (s,a) (t,b)+ _Snoc :: Prism s t (s,a) (t,b) -instance (Choice p, Applicative f) => Snoc p f [a] [b] a b where+instance Snoc [a] [b] a b where _Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas then Left [] else Right (Prelude.init aas, Prelude.last aas) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f) => Snoc p f (Seq a) (Seq b) a b where+instance Snoc (Seq a) (Seq b) a b where _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of as :> a -> Right (as, a) EmptyR -> Left mempty {-# INLINE _Snoc #-} -instance (Choice p, Applicative f) => Snoc p f (Vector a) (Vector b) a b where+instance Snoc (Vector a) (Vector b) a b where _Snoc = prism (uncurry Vector.snoc) $ \v -> if Vector.null v then Left Vector.empty else Right (Vector.unsafeInit v, Vector.unsafeLast v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f, Prim a, Prim b) => Snoc p f (Prim.Vector a) (Prim.Vector b) a b where+instance (Prim a, Prim b) => Snoc (Prim.Vector a) (Prim.Vector b) a b where _Snoc = prism (uncurry Prim.snoc) $ \v -> if Prim.null v then Left Prim.empty else Right (Prim.unsafeInit v, Prim.unsafeLast v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f, Storable a, Storable b) => Snoc p f (Storable.Vector a) (Storable.Vector b) a b where+instance (Storable a, Storable b) => Snoc (Storable.Vector a) (Storable.Vector b) a b where _Snoc = prism (uncurry Storable.snoc) $ \v -> if Storable.null v then Left Storable.empty else Right (Storable.unsafeInit v, Storable.unsafeLast v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f, Unbox a, Unbox b) => Snoc p f (Unbox.Vector a) (Unbox.Vector b) a b where+instance (Unbox a, Unbox b) => Snoc (Unbox.Vector a) (Unbox.Vector b) a b where _Snoc = prism (uncurry Unbox.snoc) $ \v -> if Unbox.null v then Left Unbox.empty else Right (Unbox.unsafeInit v, Unbox.unsafeLast v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f) => Snoc p f StrictB.ByteString StrictB.ByteString Word8 Word8 where+instance Snoc StrictB.ByteString StrictB.ByteString Word8 Word8 where _Snoc = prism (uncurry StrictB.snoc) $ \v -> if StrictB.null v then Left StrictB.empty else Right (StrictB.init v, StrictB.last v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f) => Snoc p f LazyB.ByteString LazyB.ByteString Word8 Word8 where+instance Snoc LazyB.ByteString LazyB.ByteString Word8 Word8 where _Snoc = prism (uncurry LazyB.snoc) $ \v -> if LazyB.null v then Left LazyB.empty else Right (LazyB.init v, LazyB.last v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f) => Snoc p f StrictT.Text StrictT.Text Char Char where+instance Snoc StrictT.Text StrictT.Text Char Char where _Snoc = prism (uncurry StrictT.snoc) $ \v -> if StrictT.null v then Left StrictT.empty else Right (StrictT.init v, StrictT.last v) {-# INLINE _Snoc #-} -instance (Choice p, Applicative f) => Snoc p f LazyT.Text LazyT.Text Char Char where+instance Snoc LazyT.Text LazyT.Text Char Char where _Snoc = prism (uncurry LazyT.snoc) $ \v -> if LazyT.null v then Left LazyT.empty else Right (LazyT.init v, LazyT.last v)@@ -381,7 +406,7 @@ -- '_init' :: 'Traversal'' ('Seq' a) ('Seq' a) -- '_init' :: 'Traversal'' ('Vector' a) ('Vector' a) -- @-_init :: Snoc (->) f s s a a => LensLike' f s s+_init :: Snoc s s a a => Traversal' s s _init = _Snoc._1 {-# INLINE _init #-} @@ -424,23 +449,53 @@ -- '_last' :: 'Traversal'' ('Seq' a) a -- '_last' :: 'Traversal'' ('Vector' a) a -- @-_last :: Snoc (->) f s s a a => LensLike' f s a+_last :: Snoc s s a a => Traversal' s a _last = _Snoc._2 {-# INLINE _last #-} -- | 'snoc' an element onto the end of a container. -- -- This is an infix alias for 'snoc'.-(|>) :: Snoc Reviewed Identity s s a a => s -> a -> s+--+-- >>> Seq.fromList [] |> a+-- fromList [a]+--+-- >>> Seq.fromList [b, c] |> a+-- fromList [b,c,a]+--+-- >>> LazyT.pack "hello" |> '!'+-- "hello!"+(|>) :: Snoc s s a a => s -> a -> s (|>) = curry (simply review _Snoc) {-# INLINE (|>) #-} -- | 'snoc' an element onto the end of a container.-snoc :: Snoc Reviewed Identity s s a a => s -> a -> s+--+-- >>> snoc (Seq.fromList []) a+-- fromList [a]+--+-- >>> snoc (Seq.fromList [b, c]) a+-- fromList [b,c,a]+--+-- >>> snoc (LazyT.pack "hello") '!'+-- "hello!"+snoc :: Snoc s s a a => s -> a -> s snoc = curry (simply review _Snoc) {-# INLINE snoc #-} -- | Attempt to extract the right-most element from a container, and a version of the container without that element.-unsnoc :: Snoc (->) (Accessor (First (s, a))) s s a a => s -> Maybe (s, a)+--+-- >>> unsnoc (LazyT.pack "hello!")+-- Just ("hello",'!')+--+-- >>> unsnoc (LazyT.pack "")+-- Nothing+--+-- >>> unsnoc (Seq.fromList [b,c,a])+-- Just (fromList [b,c],a)+--+-- >>> unsnoc (Seq.fromList [])+-- Nothing+unsnoc :: Snoc s s a a => s -> Maybe (s, a) unsnoc s = simply preview _Snoc s {-# INLINE unsnoc #-}
src/Control/Lens/Each.hs view
@@ -3,21 +3,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} -#ifdef DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures #-}-#endif- #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Each--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -26,17 +23,11 @@ ----------------------------------------------------------------------------- module Control.Lens.Each (- -- * Indices- Index -- * Each- , Each(..)+ Each(..) ) where import Control.Applicative-import Control.Lens.Cons as Lens-import Control.Lens.Internal.Deque-import Control.Lens.Internal.Setter-import Control.Lens.Indexed as Lens import Control.Lens.Iso import Control.Lens.Type import Control.Lens.Traversal@@ -45,19 +36,14 @@ import Data.ByteString as StrictB import Data.ByteString.Lazy as LazyB import Data.Complex-import Data.Foldable as Foldable import Data.Functor.Identity import Data.HashMap.Lazy as HashMap-import Data.HashSet-import Data.Int import Data.IntMap as IntMap-import Data.IntSet+import Data.List.NonEmpty import Data.Map as Map-import Data.Set import Data.Sequence as Seq import Data.Text as StrictT import Data.Text.Lazy as LazyT-import Data.Traversable import Data.Tree as Tree import qualified Data.Vector as Vector import qualified Data.Vector.Primitive as Prim@@ -68,40 +54,6 @@ import Data.Vector.Unboxed (Unbox) import Data.Word --- | This is a common 'Index' type shared by 'Each', 'Control.Lens.At.At', 'Control.Lens.At.Contains' and 'Control.Lens.At.Ixed'.-type family Index (s :: *) :: *-type instance Index (e -> a) = e-type instance Index IntSet = Int-type instance Index (Set a) = a-type instance Index (HashSet a) = a-type instance Index [a] = Int-type instance Index (Seq a) = Int-type instance Index (a,b) = Int-type instance Index (a,b,c) = Int-type instance Index (a,b,c,d) = Int-type instance Index (a,b,c,d,e) = Int-type instance Index (a,b,c,d,e,f) = Int-type instance Index (a,b,c,d,e,f,g) = Int-type instance Index (a,b,c,d,e,f,g,h) = Int-type instance Index (a,b,c,d,e,f,g,h,i) = Int-type instance Index (IntMap a) = Int-type instance Index (Map k a) = k-type instance Index (HashMap k a) = k-type instance Index (Array i e) = i-type instance Index (UArray i e) = i-type instance Index (Vector.Vector a) = Int-type instance Index (Prim.Vector a) = Int-type instance Index (Storable.Vector a) = Int-type instance Index (Unboxed.Vector a) = Int-type instance Index (Complex a) = Int-type instance Index (Identity a) = ()-type instance Index (Maybe a) = ()-type instance Index (Tree a) = [Int]-type instance Index StrictT.Text = Int-type instance Index LazyT.Text = Int64-type instance Index StrictB.ByteString = Int-type instance Index LazyB.ByteString = Int64- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens@@ -120,181 +72,139 @@ -- >>> over each Char.toUpper ("hello"^.Text.packed) -- "HELLO" ----- 'each' is an 'IndexedTraversal', so it can be used to access keys in many containers:------ >>> itoListOf each $ Map.fromList [("hello",2),("world",4)]--- [("hello",2),("world",4)]--- -- >>> ("hello","world") & each.each %~ Char.toUpper -- ("HELLO","WORLD")-class (Functor f, Index s ~ Index t) => Each f s t a b | s -> a, t -> b, s b -> t, t a -> s where- each :: IndexedLensLike (Index s) f s t a b-#ifdef DEFAULT_SIGNATURES- default each :: (Applicative f, Traversable g, s ~ g a, t ~ g b, Index s ~ Int, Index t ~ Int) => IndexedLensLike Int f s t a b- each = traversed+class Each s t a b | s -> a, t -> b, s b -> t, t a -> s where+ each :: Traversal s t a b+#ifndef HLINT+ default each :: (Applicative f, Traversable g, s ~ g a, t ~ g b) => LensLike f s t a b+ each = traverse {-# INLINE each #-} #endif --- | @'each' :: 'IndexedTraversal' 'Int' (a,a) (b,b) a b@-instance (Applicative f, a~a', b~b') => Each f (a,a') (b,b') a b where- each f ~(a,b) = (,) <$> f' (0 :: Int) a <*> f' 1 b- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a) (b,b) a b@+instance (a~a', b~b') => Each (a,a') (b,b') a b where+ each f ~(a,b) = (,) <$> f a <*> f b {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a) (b,b,b) a b@-instance (Applicative f, a~a2, a~a3, b~b2, b~b3) => Each f (a,a2,a3) (b,b2,b3) a b where- each f ~(a,b,c) = (,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a) (b,b,b) a b@+instance (a~a2, a~a3, b~b2, b~b3) => Each (a,a2,a3) (b,b2,b3) a b where+ each f ~(a,b,c) = (,,) <$> f a <*> f b <*> f c {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a) (b,b,b,b) a b@-instance (Applicative f, a~a2, a~a3, a~a4, b~b2, b~b3, b~b4) => Each f (a,a2,a3,a4) (b,b2,b3,b4) a b where- each f ~(a,b,c,d) = (,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a,a) (b,b,b,b) a b@+instance (a~a2, a~a3, a~a4, b~b2, b~b3, b~b4) => Each (a,a2,a3,a4) (b,b2,b3,b4) a b where+ each f ~(a,b,c,d) = (,,,) <$> f a <*> f b <*> f c <*> f d {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a) (b,b,b,b,b) a b@-instance (Applicative f, a~a2, a~a3, a~a4, a~a5, b~b2, b~b3, b~b4, b~b5) => Each f (a,a2,a3,a4,a5) (b,b2,b3,b4,b5) a b where- each f ~(a,b,c,d,e) = (,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a,a,a) (b,b,b,b,b) a b@+instance (a~a2, a~a3, a~a4, a~a5, b~b2, b~b3, b~b4, b~b5) => Each (a,a2,a3,a4,a5) (b,b2,b3,b4,b5) a b where+ each f ~(a,b,c,d,e) = (,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a) (b,b,b,b,b,b) a b@-instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, b~b2, b~b3, b~b4, b~b5, b~b6) => Each f (a,a2,a3,a4,a5,a6) (b,b2,b3,b4,b5,b6) a b where- each f ~(a,b,c,d,e,g) = (,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a,a,a,a) (b,b,b,b,b,b) a b@+instance (a~a2, a~a3, a~a4, a~a5, a~a6, b~b2, b~b3, b~b4, b~b5, b~b6) => Each (a,a2,a3,a4,a5,a6) (b,b2,b3,b4,b5,b6) a b where+ each f ~(a,b,c,d,e,g) = (,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a) (b,b,b,b,b,b,b) a b@-instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7) => Each f (a,a2,a3,a4,a5,a6,a7) (b,b2,b3,b4,b5,b6,b7) a b where- each f ~(a,b,c,d,e,g,h) = (,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a,a,a,a,a) (b,b,b,b,b,b,b) a b@+instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7) => Each (a,a2,a3,a4,a5,a6,a7) (b,b2,b3,b4,b5,b6,b7) a b where+ each f ~(a,b,c,d,e,g,h) = (,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b) a b@-instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8) => Each f (a,a2,a3,a4,a5,a6,a7,a8) (b,b2,b3,b4,b5,b6,b7,b8) a b where- each f ~(a,b,c,d,e,g,h,i) = (,,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h <*> f' 7 i- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b) a b@+instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8) => Each (a,a2,a3,a4,a5,a6,a7,a8) (b,b2,b3,b4,b5,b6,b7,b8) a b where+ each f ~(a,b,c,d,e,g,h,i) = (,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b,b) a b@-instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8, b~b9) => Each f (a,a2,a3,a4,a5,a6,a7,a8,a9) (b,b2,b3,b4,b5,b6,b7,b8,b9) a b where- each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h <*> f' 7 i <*> f' 8 j- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' (a,a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b,b) a b@+instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8, b~b9) => Each (a,a2,a3,a4,a5,a6,a7,a8,a9) (b,b2,b3,b4,b5,b6,b7,b8,b9) a b where+ each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i <*> f j {-# INLINE each #-} #if MIN_VERSION_base(4,4,0)--- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'IndexedTraversal' 'Int' ('Complex' a) ('Complex' b) a b@-instance Applicative f => Each f (Complex a) (Complex b) a b where- each f (a :+ b) = (:+) <$> f' (0 :: Int) a <*> f' (1 :: Int) b- where f' = Lens.indexed f+-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'Traversal' ('Complex' a) ('Complex' b) a b@+instance Each (Complex a) (Complex b) a b where+ each f (a :+ b) = (:+) <$> f a <*> f b {-# INLINE each #-} #else--- | @'each' :: 'IndexedTraversal' 'Int' ('Complex' a) ('Complex' b) a b@-instance (Applicative f, RealFloat a, RealFloat b) => Each f (Complex a) (Complex b) a b where- each f (a :+ b) = (:+) <$> f' (0 :: Int) a <*> f' 1 b- where f' = Lens.indexed f+-- | @'each' :: 'Traversal' ('Complex' a) ('Complex' b) a b@+instance (RealFloat a, RealFloat b) => Each (Complex a) (Complex b) a b where+ each f (a :+ b) = (:+) <$> f a <*> f b {-# INLINE each #-} #endif --- | @'each' :: 'IndexedTraversal' c ('Map' c a) ('Map' c b) a b@-instance Applicative f => Each f (Map c a) (Map c b) a b where- each f m = sequenceA $ Map.mapWithKey f' m- where f' = Lens.indexed f- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@+instance (c ~ d) => Each (Map c a) (Map d b) a b --- | @'each' :: 'IndexedTraversal' c ('Map' c a) ('Map' c b) a b@-instance Applicative f => Each f (IntMap a) (IntMap b) a b where- each f m = sequenceA $ IntMap.mapWithKey f' m- where f' = Lens.indexed f- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@+instance Each (IntMap a) (IntMap b) a b --- | @'each' :: 'IndexedTraversal' c ('HashMap' c a) ('HashMap' c b) a b@-instance Applicative f => Each f (HashMap c a) (HashMap c b) a b where- each = HashMap.traverseWithKey . Lens.indexed- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('HashMap' c a) ('HashMap' c b) a b@+instance (c ~ d) => Each (HashMap c a) (HashMap d b) a b --- | @'each' :: 'IndexedTraversal' 'Int' [a] [b] a b@-instance Applicative f => Each f [a] [b] a b where- each = traversed- {-# INLINE each #-}+-- | @'each' :: 'Traversal' [a] [b] a b@+instance Each [a] [b] a b --- | @'each' :: 'IndexedTraversal' () ('Identity' a) ('Identity' b) a b@-instance Functor f => Each f (Identity a) (Identity b) a b where- each f (Identity a) = Identity <$> Lens.indexed f () a- {-# INLINE each #-}+-- | @'each' :: 'Traversal' (NonEmpty a) (NonEmpty b) a b@+instance Each (NonEmpty a) (NonEmpty b) a b --- | @'each' :: 'IndexedTraversal' () ('Maybe' a) ('Maybe' b) a b@-instance Applicative f => Each f (Maybe a) (Maybe b) a b where- each f (Just a) = Just <$> Lens.indexed f () a- each _ Nothing = pure Nothing- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Identity' a) ('Identity' b) a b@+instance Each (Identity a) (Identity b) a b --- | @'each' :: 'IndexedTraversal' 'Int' ('Seq' a) ('Seq' b) a b@-instance Applicative f => Each f (Seq a) (Seq b) a b where- each = traversed- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Maybe' a) ('Maybe' b) a b@+instance Each (Maybe a) (Maybe b) a b --- | @'each' :: 'IndexedTraversal' ['Int'] ('Tree' a) ('Tree' b) a b@-instance Applicative f => Each f (Tree a) (Tree b) a b where- each pafb = go (BD 0 [] 0 []) where- go dq (Node a as) = Node <$> Lens.indexed pafb (Foldable.toList dq) a <*> itraverse (\i n -> go (Lens.snoc dq i) n) as- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Seq' a) ('Seq' b) a b@+instance Each (Seq a) (Seq b) a b --- | @'each' :: 'IndexedTraversal' 'Int' ('Vector.Vector' a) ('Vector.Vector' b) a b@-instance Applicative f => Each f (Vector.Vector a) (Vector.Vector b) a b where- each = traversed- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Tree' a) ('Tree' b) a b@+instance Each (Tree a) (Tree b) a b --- | @'each' :: ('Prim' a, 'Prim' b) => 'IndexedTraversal' 'Int' ('Prim.Vector' a) ('Prim.Vector' b) a b@-instance (Applicative f, Prim a, Prim b) => Each f (Prim.Vector a) (Prim.Vector b) a b where- each f v = Prim.fromListN (Prim.length v) <$> traversed (Indexed f') (Prim.toList v)- where f' = Lens.indexed f- {-# INLINE each #-}+-- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@+instance Each (Vector.Vector a) (Vector.Vector b) a b --- | @'each' :: ('Storable' a, 'Storable' b) => 'IndexedTraversal' 'Int' ('Storable.Vector' a) ('Storable.Vector' b) a b@-instance (Applicative f, Storable a, Storable b) => Each f (Storable.Vector a) (Storable.Vector b) a b where- each f v = Storable.fromListN (Storable.length v) <$> traversed (Indexed f') (Storable.toList v)- where f' = Lens.indexed f+-- | @'each' :: ('Prim' a, 'Prim' b) => 'Traversal' ('Prim.Vector' a) ('Prim.Vector' b) a b@+instance (Prim a, Prim b) => Each (Prim.Vector a) (Prim.Vector b) a b where+ each f v = Prim.fromListN (Prim.length v) <$> traverse f (Prim.toList v) {-# INLINE each #-} --- | @'each' :: ('Unbox' a, 'Unbox' b) => 'IndexedTraversal' 'Int' ('Unboxed.Vector' a) ('Unboxed.Vector' b) a b@-instance (Applicative f, Unbox a, Unbox b) => Each f (Unboxed.Vector a) (Unboxed.Vector b) a b where- each f v = Unboxed.fromListN (Unboxed.length v) <$> traversed (Indexed f') (Unboxed.toList v)- where f' = Lens.indexed f+-- | @'each' :: ('Storable' a, 'Storable' b) => 'Traversal' ('Storable.Vector' a) ('Storable.Vector' b) a b@+instance (Storable a, Storable b) => Each (Storable.Vector a) (Storable.Vector b) a b where+ each f v = Storable.fromListN (Storable.length v) <$> traverse f (Storable.toList v) {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@-instance Applicative f => Each f StrictT.Text StrictT.Text Char Char where- each = iso StrictT.unpack StrictT.pack . traversed+-- | @'each' :: ('Unbox' a, 'Unbox' b) => 'Traversal' ('Unboxed.Vector' a) ('Unboxed.Vector' b) a b@+instance (Unbox a, Unbox b) => Each (Unboxed.Vector a) (Unboxed.Vector b) a b where+ each f v = Unboxed.fromListN (Unboxed.length v) <$> traverse f (Unboxed.toList v) {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyT.Text' 'LazyT.Text' 'Char' 'Char'@-instance Applicative f => Each f LazyT.Text LazyT.Text Char Char where- each = iso LazyT.unpack LazyT.pack . traversed64+-- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@+instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where+ each = iso StrictT.unpack StrictT.pack . traversed {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' 'StrictB.ByteString' 'StrictB.ByteString' 'Word8' 'Word8'@-instance Applicative f => Each f StrictB.ByteString StrictB.ByteString Word8 Word8 where- each = iso StrictB.unpack StrictB.pack . traversed+-- | @'each' :: 'Traversal' 'LazyT.Text' 'LazyT.Text' 'Char' 'Char'@+instance (a ~ Char, b ~ Char) => Each LazyT.Text LazyT.Text a b where+ each = iso LazyT.unpack LazyT.pack . traverse {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyB.ByteString' 'LazyB.ByteString' 'Word8' 'Word8'@-instance Applicative f => Each f LazyB.ByteString LazyB.ByteString Word8 Word8 where- each = iso LazyB.unpack LazyB.pack . traversed64+-- | @'each' :: 'Traversal' 'StrictB.ByteString' 'StrictB.ByteString' 'Word8' 'Word8'@+instance (a ~ Word8, b ~ Word8) => Each StrictB.ByteString StrictB.ByteString a b where+ each = iso StrictB.unpack StrictB.pack . traverse {-# INLINE each #-} --- | @'each' :: 'Ix' i => 'IndexedTraversal' i ('Array' i a) ('Array' i b) a b@-instance (Applicative f, Ix i) => Each f (Array i a) (Array i b) a b where- each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> Lens.indexed f i a) (IArray.assocs arr)+-- | @'each' :: 'Traversal' 'LazyB.ByteString' 'LazyB.ByteString' 'Word8' 'Word8'@+instance (a ~ Word8, b ~ Word8) => Each LazyB.ByteString LazyB.ByteString a b where+ each = iso LazyB.unpack LazyB.pack . traverse {-# INLINE each #-} --- | @'each' :: ('Ix' i, 'IArray' 'UArray' a, 'IArray' 'UArray' b) => 'IndexedTraversal' i ('Array' i a) ('Array' i b) a b@-instance (Applicative f, Ix i, IArray UArray a, IArray UArray b) => Each f (UArray i a) (UArray i b) a b where- each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> Lens.indexed f i a) (IArray.assocs arr)+-- | @'each' :: 'Ix' i => 'Traversal' ('Array' i a) ('Array' i b) a b@+instance (Ix i, i ~ j) => Each (Array i a) (Array j b) a b where+ each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr) {-# INLINE each #-} --- | @'each' :: 'Control.Lens.IndexedSetter' i (i -> a) (i -> b) a b@-instance Settable f => Each f (i -> a) (i -> b) a b where- each f g = pure (\i -> untaintedDot (Lens.indexed f i) (g i))+-- | @'each' :: ('Ix' i, 'IArray' 'UArray' a, 'IArray' 'UArray' b) => 'Traversal' ('Array' i a) ('Array' i b) a b@+instance (Ix i, IArray UArray a, IArray UArray b, i ~ j) => Each (UArray i a) (UArray j b) a b where+ each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr) {-# INLINE each #-}
+ src/Control/Lens/Empty.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE DefaultSignatures #-}++-------------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Empty+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+-------------------------------------------------------------------------------+module Control.Lens.Empty+ (+ AsEmpty(..)+ ) where++import Control.Lens.Iso+import Control.Lens.Prism+import Control.Lens.Review+import Data.ByteString as StrictB+import Data.ByteString.Lazy as LazyB+import Data.HashMap.Lazy as HashMap+import Data.HashSet as HashSet+import Data.IntMap as IntMap+import Data.IntSet as IntSet+import Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Profunctor.Unsafe+import Data.Sequence as Seq+import Data.Set as Set+import Data.Text as StrictT+import Data.Text.Lazy as LazyT+import Data.Vector as Vector+import Data.Vector.Unboxed as Unboxed+import Data.Vector.Storable as Storable++#ifndef mingw32_HOST_OS+import GHC.Event+#endif++class AsEmpty a where+ -- |+ --+ -- >>> isn't _Empty [1,2,3]+ -- True+ _Empty :: Prism' a ()+#ifndef HLINT+ default _Empty :: (Monoid a, Eq a) => Prism' a ()+ _Empty = only mempty+ {-# INLINE _Empty #-}+#endif++{- Default Monoid instances -}+instance AsEmpty Ordering+instance AsEmpty ()+instance AsEmpty Any+instance AsEmpty All+#ifndef mingw32_HOST_OS+instance AsEmpty Event+#endif+instance (Eq a, Num a) => AsEmpty (Product a)+instance (Eq a, Num a) => AsEmpty (Sum a)++instance AsEmpty (Maybe a) where+ _Empty = _Nothing+ {-# INLINE _Empty #-}++instance AsEmpty (Last a) where+ _Empty = nearly (Last Nothing) (isNothing .# getLast)+ {-# INLINE _Empty #-}++instance AsEmpty (First a) where+ _Empty = nearly (First Nothing) (isNothing .# getFirst)+ {-# INLINE _Empty #-}++instance AsEmpty a => AsEmpty (Dual a) where+ _Empty = iso getDual Dual . _Empty+ {-# INLINE _Empty #-}++instance (AsEmpty a, AsEmpty b) => AsEmpty (a,b) where+ _Empty = prism' (\() -> (_Empty # (), _Empty # ())) $ \(s,s') -> case _Empty Left s of+ Left () -> case _Empty Left s' of+ Left () -> Just ()+ _ -> Nothing+ _ -> Nothing+ {-# INLINE _Empty #-}++instance (AsEmpty a, AsEmpty b, AsEmpty c) => AsEmpty (a,b,c) where+ _Empty = prism' (\() -> (_Empty # (), _Empty # (), _Empty # ())) $ \(s,s',s'') -> case _Empty Left s of+ Left () -> case _Empty Left s' of+ Left () -> case _Empty Left s'' of+ Left () -> Just ()+ Right _ -> Nothing+ Right _ -> Nothing+ Right _ -> Nothing+ {-# INLINE _Empty #-}++instance AsEmpty [a] where+ _Empty = nearly [] Prelude.null+ {-# INLINE _Empty #-}++instance AsEmpty (Map k a) where+ _Empty = nearly Map.empty Map.null+ {-# INLINE _Empty #-}++instance AsEmpty (HashMap k a) where+ _Empty = nearly HashMap.empty HashMap.null+ {-# INLINE _Empty #-}++instance AsEmpty (IntMap a) where+ _Empty = nearly IntMap.empty IntMap.null+ {-# INLINE _Empty #-}++instance AsEmpty (Set a) where+ _Empty = nearly Set.empty Set.null+ {-# INLINE _Empty #-}++instance AsEmpty (HashSet a) where+ _Empty = nearly HashSet.empty HashSet.null+ {-# INLINE _Empty #-}++instance AsEmpty IntSet where+ _Empty = nearly IntSet.empty IntSet.null+ {-# INLINE _Empty #-}++instance AsEmpty (Vector.Vector a) where+ _Empty = nearly Vector.empty Vector.null+ {-# INLINE _Empty #-}++instance Unbox a => AsEmpty (Unboxed.Vector a) where+ _Empty = nearly Unboxed.empty Unboxed.null+ {-# INLINE _Empty #-}++instance Storable a => AsEmpty (Storable.Vector a) where+ _Empty = nearly Storable.empty Storable.null+ {-# INLINE _Empty #-}++instance AsEmpty (Seq a) where+ _Empty = nearly Seq.empty Seq.null+ {-# INLINE _Empty #-}++instance AsEmpty StrictB.ByteString where+ _Empty = nearly StrictB.empty StrictB.null+ {-# INLINE _Empty #-}++instance AsEmpty LazyB.ByteString where+ _Empty = nearly LazyB.empty LazyB.null+ {-# INLINE _Empty #-}++instance AsEmpty StrictT.Text where+ _Empty = nearly StrictT.empty StrictT.null+ {-# INLINE _Empty #-}++instance AsEmpty LazyT.Text where+ _Empty = nearly LazyT.empty LazyT.null+ {-# INLINE _Empty #-}
src/Control/Lens/Equality.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Equality--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -26,8 +26,8 @@ , Identical(..) ) where -import Control.Lens.Internal.Setter import Control.Lens.Type+import Data.Functor.Identity #ifdef HLINT {-# ANN module "HLint: ignore Use id" #-}@@ -46,7 +46,7 @@ Identical :: Identical a b a b -- | When you see this as an argument to a function, it expects an 'Equality'.-type AnEquality s t a b = Identical a (Mutator b) a (Mutator b) -> Identical a (Mutator b) s (Mutator t)+type AnEquality s t a b = Identical a (Identity b) a (Identity b) -> Identical a (Identity b) s (Identity t) -- | A 'Simple' 'AnEquality'. type AnEquality' s a = AnEquality s s a a@@ -74,6 +74,6 @@ -- | This is an adverb that can be used to modify many other 'Lens' combinators to make them require -- simple lenses, simple traversals, simple prisms or simple isos as input.-simply :: (Overloaded' p f s a -> r) -> Overloaded' p f s a -> r+simply :: (Optic' p f s a -> r) -> Optic' p f s a -> r simply = id {-# INLINE simply #-}
+ src/Control/Lens/Extras.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.List.Lens+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- A few extra names that didn't make it into Control.Lens.+--+----------------------------------------------------------------------------+module Control.Lens.Extras+ ( is+ , module Data.Data.Lens+ ) where++import Control.Lens+import Data.Data.Lens++-- $setup+-- >>> import Control.Lens+-- >>> import Numeric.Lens (hex)++-- | Check to see if this 'Prism' matches.+--+-- >>> is _Left (Right 12)+-- False+--+-- >>> is hex "3f79"+-- True+is :: APrism s t a b -> s -> Bool+is k = not . isn't k+{-# INLINE is #-}
src/Control/Lens/Fold.hs view
@@ -11,7 +11,7 @@ ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -23,7 +23,7 @@ -- @'Data.Foldable.foldMap' :: ('Foldable' t, 'Monoid' m) => (a -> m) -> t a -> m@. -- Since we want to be able to work with monomorphic containers, we could -- generalize this signature to @forall m. 'Monoid' m => (a -> m) -> s -> m@,--- and then decorate it with 'Accessor' to obtain+-- and then decorate it with 'Const' to obtain -- -- @type 'Fold' s a = forall m. 'Monoid' m => 'Getting' m s a@ --@@ -54,8 +54,9 @@ , has, hasn't -- ** Building Folds- , folding+ , folding, ifolding , folded+ , folded64 , unfolded , iterated , filtered@@ -70,7 +71,7 @@ , foldMapOf, foldOf , foldrOf, foldlOf , toListOf- , anyOf, allOf+ , anyOf, allOf, noneOf , andOf, orOf , productOf, sumOf , traverseOf_, forOf_, sequenceAOf_@@ -84,6 +85,7 @@ , maximumOf, minimumOf , maximumByOf, minimumByOf , findOf+ , findMOf , foldrOf', foldlOf' , foldr1Of, foldl1Of , foldr1Of', foldl1Of'@@ -100,12 +102,14 @@ , ifoldlOf , ianyOf , iallOf+ , inoneOf , itraverseOf_ , iforOf_ , imapMOf_ , iforMOf_ , iconcatMapOf , ifindOf+ , ifindMOf , ifoldrOf' , ifoldlOf' , ifoldrMOf@@ -125,6 +129,12 @@ , Rightmost , Traversed , Sequenced++ -- * Fold with Reified Monoid+ , foldBy+ , foldByOf+ , foldMapBy+ , foldMapByOf ) where import Control.Applicative as Applicative@@ -140,7 +150,9 @@ import Control.Monad.Reader import Control.Monad.State import Data.Foldable as Foldable+import Data.Functor.Apply import Data.Functor.Compose+import Data.Int (Int64) import Data.Maybe import Data.Monoid import Data.Profunctor@@ -151,6 +163,7 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Control.Lens.Extras (is) -- >>> import Data.Function -- >>> import Data.List.Lens -- >>> import Debug.SimpleReflect.Expr@@ -185,7 +198,11 @@ folding sfa agb = coerce . traverse_ agb . sfa {-# INLINE folding #-} --- | Obtain a 'Fold' from any 'Foldable'.+ifolding :: (Foldable f, Indexable i p, Contravariant g, Applicative g) => (s -> f (i, a)) -> Over p g s t a b+ifolding sfa f = coerce . traverse_ (coerce . uncurry (indexed f)) . sfa+{-# INLINE ifolding #-}++-- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position. -- -- >>> Just 3^..folded -- [3]@@ -195,11 +212,20 @@ -- -- >>> [(1,2),(3,4)]^..folded.both -- [1,2,3,4]-folded :: Foldable f => Fold (f a) a-folded f = coerce . getFolding . foldMap (Folding #. f)+folded :: Foldable f => IndexedFold Int (f a) a+folded = conjoined folded' (indexing folded') {-# INLINE folded #-} --- | 'Fold' by repeating the input forever.+-- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position.+folded64 :: Foldable f => IndexedFold Int64 (f a) a+folded64 = conjoined folded' (indexing64 folded')+{-# INLINE folded64 #-}++folded' :: Foldable f => Fold (f a) a+folded' f = coerce . getFolding . foldMap (Folding #. f)+{-# INLINE folded' #-}++-- | Form a 'Fold1' by repeating the input forever. -- -- @ -- 'repeat' ≡ 'toListOf' 'repeated'@@ -207,8 +233,8 @@ -- -- >>> timingOut $ 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+repeated :: Fold1 a a+repeated f a = as where as = f a .> as {-# INLINE repeated #-} -- | A 'Fold' that replicates its input @n@ times.@@ -226,12 +252,12 @@ go n = m *> go (n - 1) {-# INLINE replicated #-} --- | Transform a 'Fold' into a 'Fold' that loops over its elements over and over.+-- | Transform a non-empty 'Fold' into a 'Fold1' that loops over its elements over and over. -- -- >>> timingOut $ [1,2,3]^..taking 7 (cycled traverse) -- [1,2,3,1,2,3,1]-cycled :: (Contravariant f, Applicative f) => LensLike f s t a b -> LensLike f s t a b-cycled l f a = as where as = l f a *> as+cycled :: (Contravariant f, Apply 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 #-} -- | Build a 'Fold' that unfolds its values from a seed.@@ -249,19 +275,19 @@ Nothing -> noEffect {-# INLINE unfolded #-} --- | @x '^.' 'iterated' f@ returns an infinite 'Fold' of repeated applications of @f@ to @x@.+-- | @x '^.' 'iterated' f@ returns an infinite 'Fold1' of repeated applications of @f@ to @x@. -- -- @ -- 'toListOf' ('iterated' f) a ≡ 'iterate' f a -- @-iterated :: (a -> a) -> Fold a a+iterated :: (a -> a) -> Fold1 a a iterated f g a0 = go a0 where- go a = g a *> go (f a)+ go a = g a .> go (f a) {-# INLINE iterated #-} --- | Obtain a 'Fold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal').+-- | Obtain an 'AffineFold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). ----- Note: This is /not/ a legal 'Traversal', unless you are very careful not to invalidate the predicate on the target.+-- Note: This is /not/ a legal 'AffineTraversal', unless you are very careful not to invalidate the predicate on the target. -- -- Note: This is also /not/ a legal 'Prism', unless you are very careful not to inject a value that matches the predicate. --@@ -271,13 +297,13 @@ -- 'Control.Lens.Setter.over' evens 'succ' '.' 'Control.Lens.Setter.over' evens 'succ' '/=' 'Control.Lens.Setter.over' evens ('succ' '.' 'succ') -- @ ----- So, in order for this to qualify as a legal 'Traversal' you can only use it for actions that preserve the result of the predicate!+-- So, in order for this to qualify as a legal 'AffineTraversal' you can only use it for actions that preserve the result of the predicate! -- -- >>> [1..10]^..folded.filtered even -- [2,4,6,8,10] -- -- This will preserve an index if it is present.-filtered :: (Choice p, Applicative f) => (a -> Bool) -> Overloaded' p f a a+filtered :: (Choice p, Applicative f) => (a -> Bool) -> Optic' p f a a filtered p = dimap (\x -> if p x then Right x else Left x) (either pure id) . right' {-# INLINE filtered #-} @@ -367,8 +393,8 @@ -- and 'Traversal' fusion is not sound. droppingWhile :: (Conjoined p, Profunctor q, Applicative f) => (a -> Bool)- -> Overloading p q (Compose (State Bool) f) s t a a- -> Overloading p q f s t a a+ -> Optical p q (Compose (State Bool) f) s t a a+ -> Optical p q f s t a a droppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where g = cotabulate $ \wa -> Compose $ state $ \b -> let a = extract wa@@ -402,7 +428,7 @@ -- 'foldMapOf' :: 'Getting' r s a -> (a -> r) -> s -> r -- @ foldMapOf :: Profunctor p => Accessing p r s a -> p a r -> s -> r-foldMapOf l f = runAccessor #. l (Accessor #. f)+foldMapOf l f = getConst #. l (Const #. f) {-# INLINE foldMapOf #-} -- | @@@ -422,7 +448,7 @@ -- 'foldOf' :: 'Monoid' m => 'Prism'' s m -> s -> m -- @ foldOf :: Getting a s a -> s -> a-foldOf l = runAccessor #. l Accessor+foldOf l = getConst #. l Const {-# INLINE foldOf #-} -- | Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'.@@ -567,7 +593,7 @@ -- >>> anyOf both (=='x') ('x','y') -- True -- >>> import Data.Data.Lens--- >>> anyOf biplate (== "world") (((),2::Int),"hello",("world",11))+-- >>> anyOf biplate (== "world") (((),2::Int),"hello",("world",11::Int)) -- True -- -- @@@ -617,6 +643,29 @@ allOf l f = getAll #. foldMapOf l (All #. f) {-# INLINE allOf #-} +-- | Returns 'True' only if no targets of a 'Fold' satisfy a predicate.+--+-- >>> noneOf each (is _Nothing) (Just 3, Just 4, Just 5)+-- True+-- >>> noneOf (folded.folded) (<10) [[13,99,20],[3,71,42]]+-- False+--+-- @+-- 'inoneOf' l = 'noneOf' l '.' 'Indexed'+-- @+--+-- @+-- 'noneOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'noneOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'noneOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'noneOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'noneOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool'+-- 'noneOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool'+-- @+noneOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool+noneOf l f = not . anyOf l f+{-# INLINE noneOf #-}+ -- | Calculate the 'Product' of every number targeted by a 'Fold'. -- -- >>> productOf both (4,5)@@ -948,7 +997,7 @@ -- 'concatMapOf' :: 'Traversal'' s a -> (a -> [r]) -> s -> [r] -- @ concatMapOf :: Profunctor p => Accessing p [r] s a -> p a [r] -> s -> [r]-concatMapOf l ces = runAccessor #. l (Accessor #. ces)+concatMapOf l ces = getConst #. l (Const #. ces) {-# INLINE concatMapOf #-} -- | Concatenate all of the lists targeted by a 'Fold' into a longer list.@@ -969,7 +1018,7 @@ -- 'concatOf' :: 'Traversal'' s [r] -> s -> [r] -- @ concatOf :: Getting [r] s [r] -> s -> [r]-concatOf l = runAccessor #. l Accessor+concatOf l = getConst #. l Const {-# INLINE concatOf #-} @@ -1341,6 +1390,46 @@ findOf l p = foldrOf l (cotabulate $ \wa y -> if corep p wa then Just (extract wa) else y) Nothing {-# INLINE findOf #-} +-- | The 'findMOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'),+-- a monadic predicate and a structure and returns in the monad the leftmost element of the structure+-- matching the predicate, or 'Nothing' if there is no such element.+--+-- >>> findMOf each ( \x -> print ("Checking " ++ show x) >> return (even x)) (1,3,4,6)+-- "Checking 1"+-- "Checking 3"+-- "Checking 4"+-- Just 4+--+-- >>> findMOf each ( \x -> print ("Checking " ++ show x) >> return (even x)) (1,3,5,7)+-- "Checking 1"+-- "Checking 3"+-- "Checking 5"+-- "Checking 7"+-- Nothing+--+-- @+-- 'findMOf' :: ('Monad' m, 'Getter' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'findMOf' :: ('Monad' m, 'Fold' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'findMOf' :: ('Monad' m, 'Iso'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'findMOf' :: ('Monad' m, 'Lens'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'findMOf' :: ('Monad' m, 'Traversal'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a)+-- @+--+-- @+-- 'findMOf' 'folded' :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m (Maybe a)+-- 'ifindMOf' l ≡ 'findMOf' l '.' 'Indexed'+-- @+--+-- A simpler version that didn't permit indexing, would be:+--+-- @+-- 'findMOf' :: Monad m => 'Getting' ('Endo' (m ('Maybe' a))) s a -> (a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'findMOf' l p = 'foldrOf' l (\a y -> p a >>= \x -> if x then return ('Just' a) else y) $ return 'Nothing'+-- @+findMOf :: (Monad m, Conjoined p) => Accessing p (Endo (m (Maybe a))) s a -> p a (m Bool) -> s -> m (Maybe a)+findMOf l p = foldrOf l (cotabulate $ \wa y -> corep p wa >>= \r -> if r then return (Just (extract wa)) else y) $ return Nothing+{-# INLINE findMOf #-}+ -- | A variant of 'foldrOf' 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.@@ -1569,7 +1658,7 @@ -- 'pre' :: 'Simple' 'Prism' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- @ pre :: Getting (First a) s a -> IndexPreservingGetter s (Maybe a)-pre l = dimap (getFirst . runAccessor #. l (Accessor #. First #. Just)) coerce+pre l = dimap (getFirst . getConst #. l (Const #. First #. Just)) coerce {-# INLINE pre #-} -- | This converts an 'IndexedFold' to an 'IndexPreservingGetter' that returns the first index@@ -1582,7 +1671,7 @@ -- 'ipre' :: 'Simple' ('IndexedLens' i) s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- @ ipre :: IndexedGetting i (First (i, a)) s a -> IndexPreservingGetter s (Maybe (i, a))-ipre l = dimap (getFirst . runAccessor #. l (Indexed $ \i a -> Accessor (First (Just (i, a))))) coerce+ipre l = dimap (getFirst . getConst #. l (Indexed $ \i a -> Const (First (Just (i, a))))) coerce {-# INLINE ipre #-} ------------------------------------------------------------------------------@@ -1740,7 +1829,7 @@ preuse l = gets (preview l) {-# INLINE preuse #-} --- | Retrieve the first index and value targeted by an 'IndexedFold' or 'IndexedTraversal' (or 'Just' the index +-- | Retrieve the first index and value targeted by an 'IndexedFold' or 'IndexedTraversal' (or 'Just' the index -- and result from an 'IndexedGetter' or 'IndexedLens') into the current state. -- -- @@@ -1806,7 +1895,7 @@ -- -- /NB:/ To write back through an 'Iso', you want to use 'Control.Lens.Isomorphic.from'. -- Similarly, to write back through an 'Prism', you want to use 'Control.Lens.Review.re'.-backwards :: (Profunctor p, Profunctor q) => Overloading p q (Backwards f) s t a b -> Overloading p q f s t a b+backwards :: (Profunctor p, Profunctor q) => Optical p q (Backwards f) s t a b -> Optical p q f s t a b backwards l f = forwards #. l (Backwards #. f) {-# INLINE backwards #-} @@ -1910,6 +1999,25 @@ iallOf l = allOf l .# Indexed {-# INLINE iallOf #-} +-- | Return whether or not none of the elements viewed through an 'IndexedFold' or 'IndexedTraversal'+-- satisfy a predicate, with access to the @i@.+--+-- When you don't need access to the index then 'noneOf' is more flexible in what it accepts.+--+-- @+-- 'noneOf' l ≡ 'inoneOf' l '.' 'const'+-- @+--+-- @+-- 'inoneOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool'+-- 'inoneOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool'+-- 'inoneOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool'+-- 'inoneOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool'+-- @+inoneOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool+inoneOf l = noneOf l .# Indexed+{-# INLINE inoneOf #-}+ -- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the @i@, discarding the results. -- -- When you don't need access to the index then 'traverseOf_' is more flexible in what it accepts.@@ -2013,7 +2121,7 @@ iconcatMapOf = ifoldMapOf {-# INLINE iconcatMapOf #-} --- | The 'findOf' function takes an 'IndexedFold' or 'IndexedTraversal', a predicate that is also+-- | The 'ifindOf' function takes an 'IndexedFold' or 'IndexedTraversal', a predicate that is also -- supplied the index, a structure and returns the left-most element of the structure -- matching the predicate, or 'Nothing' if there is no such element. --@@ -2033,6 +2141,26 @@ ifindOf l = findOf l .# Indexed {-# INLINE ifindOf #-} +-- | The 'ifindMOf' function takes an 'IndexedFold' or 'IndexedTraversal', a monadic predicate that is also+-- supplied the index, a structure and returns in the monad the left-most element of the structure+-- matching the predicate, or 'Nothing' if there is no such element.+--+-- When you don't need access to the index then 'findMOf' is more flexible in what it accepts.+--+-- @+-- 'findMOf' l ≡ 'ifindMOf' l '.' 'const'+-- @+--+-- @+-- 'ifindMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'ifindMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'ifindMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a)+-- 'ifindMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a)+-- @+ifindMOf :: Monad m => IndexedGetting i (Endo (m (Maybe a))) s a -> (i -> a -> m Bool) -> s -> m (Maybe a)+ifindMOf l = findMOf l .# Indexed+{-# INLINE ifindMOf #-}+ -- | /Strictly/ fold right over the elements of a structure with an index. -- -- When you don't need access to the index then 'foldrOf'' is more flexible in what it accepts.@@ -2180,7 +2308,7 @@ -- access to both the value and the index. -- -- Note: As with 'filtered', this is /not/ a legal 'IndexedTraversal', unless you are very careful not to invalidate the predicate on the target!-ifiltered :: (Indexable i p, Applicative f) => (i -> a -> Bool) -> Overloading' p (Indexed i) f a a+ifiltered :: (Indexable i p, Applicative f) => (i -> a -> Bool) -> Optical' p (Indexed i) f a a ifiltered p f = Indexed $ \i a -> if p i a then indexed f i a else pure a {-# INLINE ifiltered #-} @@ -2197,10 +2325,10 @@ -- @ itakingWhile :: (Indexable i p, Profunctor q, Contravariant f, Applicative f) => (i -> a -> Bool)- -> Overloading (Indexed i) q (Accessor (Endo (f s))) s s a a- -> Overloading p q f s s a a-itakingWhile p l f = (flip appEndo noEffect .# runAccessor) `rmap` l g where- g = Indexed $ \i a -> Accessor . Endo $ if p i a then (indexed f i a *>) else const noEffect+ -> Optical (Indexed i) q (Const (Endo (f s))) s s a a+ -> Optical p q f s s a a+itakingWhile p l f = (flip appEndo noEffect .# getConst) `rmap` l g where+ g = Indexed $ \i a -> Const . Endo $ if p i a then (indexed f i a *>) else const noEffect {-# INLINE itakingWhile #-} -- | Obtain an 'IndexedFold' by dropping elements from another 'IndexedFold', 'IndexedLens', 'IndexedGetter' or 'IndexedTraversal' while a predicate holds.@@ -2219,8 +2347,8 @@ -- 'True', then you will break the 'Traversal' laws and 'Traversal' fusion will no longer be sound. idroppingWhile :: (Indexable i p, Profunctor q, Applicative f) => (i -> a -> Bool)- -> Overloading (Indexed i) q (Compose (State Bool) f) s t a a- -> Overloading p q f s t a a+ -> Optical (Indexed i) q (Compose (State Bool) f) s t a a+ -> Optical p q f s t a a idroppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where g = Indexed $ \ i a -> Compose $ state $ \b -> let b' = b && p i a@@ -2244,3 +2372,19 @@ skip :: a -> () skip _ = () {-# INLINE skip #-}++------------------------------------------------------------------------------+-- Folds with Reified Monoid+------------------------------------------------------------------------------++foldBy :: Foldable t => (a -> a -> a) -> a -> t a -> a+foldBy f z = reifyFold f z (foldMap M)++foldByOf :: (forall i. Getting (M a i) s a) -> (a -> a -> a) -> a -> s -> a+foldByOf l f z = reifyFold f z (foldMapOf l M)++foldMapBy :: Foldable t => (r -> r -> r) -> r -> (a -> r) -> t a -> r+foldMapBy f z g = reifyFold f z (foldMap (M #. g))++foldMapByOf :: (forall s. Getting (M r s) t a) -> (r -> r -> r) -> r -> (a -> r) -> t -> r+foldMapByOf l f z g = reifyFold f z (foldMapOf l (M #. g))
src/Control/Lens/Getter.hs view
@@ -12,7 +12,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Getter--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -21,17 +21,16 @@ -- -- A @'Getter' s a@ is just any function @(s -> a)@, which we've flipped -- into continuation passing style, @(a -> r) -> s -> r@ and decorated--- with 'Accessor' to obtain:+-- with 'Const' to obtain: ----- @type 'Getting' r s t a b = (a -> 'Accessor' r b) -> s -> 'Accessor' r t@+-- @type 'Getting' r s a = (a -> 'Const' r a) -> s -> 'Const' r s@ ----- If we restrict access to knowledge about the type 'r' and can work for--- any b and t, we could get:+-- If we restrict access to knowledge about the type 'r', we could get: ----- @type 'Getter' s a = forall r. 'Getting' r s s a a@+-- @type 'Getter' s a = forall r. 'Getting' r s a@ ----- But we actually hide the use of 'Accessor' behind a class 'Gettable'--- to error messages from type class resolution rather than at unification+-- But we actually hide the use of 'Const' behind a class 'Gettable' to+-- report error messages from type class resolution rather than at unification -- time, where they are much uglier. -- -- @type 'Getter' s a = forall f. 'Gettable' f => (a -> f a) -> s -> f s@@@ -52,6 +51,7 @@ , Accessing -- * Building Getters , to+ , ito -- * Combinators for Getters and Folds , (^.) , view, views@@ -66,10 +66,11 @@ -- * Implementation Details , Contravariant(..) , coerce, coerced- , Accessor(..)+ , Const(..) , Gettable ) where +import Control.Applicative import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Type@@ -117,9 +118,13 @@ -- >>> (0, -5)^._2.to abs -- 5 to :: (s -> a) -> IndexPreservingGetter s a-to f = dimap f coerce+to k = dimap k coerce {-# INLINE to #-} +ito :: (s -> (i, a)) -> IndexedGetter i s a+ito k = dimap k coerce . uncurry . indexed+{-# INLINE ito #-}+ -- | When you see this in a type signature it indicates that you can -- pass the function a 'Lens', 'Getter', -- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold',@@ -133,18 +138,18 @@ -- 'Control.Lens.Iso.Iso' we also restricted choices of the irrelevant @t@ and -- @b@ parameters. ----- If a function accepts a @'Getting' r s t a b@, then when @r@ is a 'Data.Monoid.Monoid', then+-- If a function accepts a @'Getting' r s a@, then when @r@ is a 'Data.Monoid.Monoid', then -- you can pass a 'Control.Lens.Fold.Fold' (or -- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a -- 'Getter' or 'Lens'.-type Getting r s a = (a -> Accessor r a) -> s -> Accessor r s+type Getting r s a = (a -> Const r a) -> s -> Const r s -- | Used to consume an 'Control.Lens.Fold.IndexedFold'.-type IndexedGetting i m s a = Indexed i a (Accessor m a) -> s -> Accessor m s+type IndexedGetting i m s a = Indexed i a (Const m a) -> s -> Const m s -- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds -- in a highly general fashion.-type Accessing p m s a = p a (Accessor m a) -> s -> Accessor m s+type Accessing p m s a = p a (Const m a) -> s -> Const m s ------------------------------------------------------------------------------- -- Getting Values@@ -193,7 +198,7 @@ -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a -- @ view :: MonadReader s m => Getting a s a -> m a-view l = Reader.asks (runAccessor #. l Accessor)+view l = Reader.asks (getConst #. l Const) {-# INLINE view #-} -- | View a function of the value pointed to by a 'Getter' or 'Lens' or the result of@@ -234,8 +239,8 @@ -- @ -- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r -- @-views :: (Profunctor p, MonadReader s m) => Overloading p (->) (Accessor r) s s a a -> p a r -> m r-views l f = Reader.asks (runAccessor #. l (Accessor #. f))+views :: (Profunctor p, MonadReader s m) => Optical p (->) (Const r) s s a a -> p a r -> m r+views l f = Reader.asks (getConst #. l (Const #. f)) {-# INLINE views #-} -- | View the value pointed to by a 'Getter' or 'Lens' or the@@ -265,7 +270,7 @@ -- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Traversal.Traversal'' s m -> m -- @ (^.) :: s -> Getting a s a -> a-s ^. l = runAccessor (l Accessor s)+s ^. l = getConst (l Const s) {-# INLINE (^.) #-} -------------------------------------------------------------------------------@@ -313,7 +318,7 @@ -- @ -- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r -- @-uses :: (Profunctor p, MonadState s m) => Overloading p (->) (Accessor r) s s a a -> p a r -> m r+uses :: (Profunctor p, MonadState s m) => Optical p (->) (Const r) s s a a -> p a r -> m r uses l f = State.gets (views l f) {-# INLINE uses #-} @@ -398,7 +403,7 @@ -- 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 a -> m (i,a)-iview l = asks (runAccessor #. l (Indexed $ \i -> Accessor #. (,) i))+iview l = asks (getConst #. l (Indexed $ \i -> Const #. (,) i)) {-# INLINE iview #-} -- | View a function of the index and value of an 'IndexedGetter' into the current environment.@@ -417,7 +422,7 @@ -- 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 a -> m (i,a)-iuse l = gets (runAccessor #. l (Indexed $ \i -> Accessor #. (,) i))+iuse l = gets (getConst #. l (Indexed $ \i -> Const #. (,) i)) {-# INLINE iuse #-} -- | Use a function of the index and value of an 'IndexedGetter' into the current state.@@ -434,12 +439,6 @@ -- The fixity and semantics are such that subsequent field accesses can be -- performed with ('Prelude..'). ----- >>> (a,b,c,d)^@._2--- (1,b)------ >>> ("hello","world","!!!")^@._2--- (1,"world")--- -- @ -- ('^@.') :: s -> 'IndexedGetter' i s a -> (i, a) -- ('^@.') :: s -> 'IndexedLens'' i s a -> (i, a)@@ -447,7 +446,7 @@ -- -- The result probably doesn't have much meaning when applied to an 'IndexedFold'. (^@.) :: s -> IndexedGetting i (i, a) s a -> (i, a)-s ^@. l = runAccessor $ l (Indexed $ \i -> Accessor #. (,) i) s+s ^@. l = getConst $ l (Indexed $ \i -> Const #. (,) i) s {-# INLINE (^@.) #-} -- | Coerce a 'Gettable' 'LensLike' to a 'Simple' 'LensLike'. This is useful
src/Control/Lens/Indexed.hs view
@@ -3,15 +3,11 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}-#ifdef DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706-#define MPTC_DEFAULTS-#endif-#endif+ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- vector, hashable #endif@@ -22,7 +18,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Indexed--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -45,10 +41,10 @@ , FunctorWithIndex(..) -- * Indexed Foldables , FoldableWithIndex(..)- , ifolding -- ** Indexed Foldable Combinators , iany , iall+ , inone, none , itraverse_ , ifor_ , imapM_@@ -72,6 +68,9 @@ , iforM , imapAccumR , imapAccumL+ -- * Indexed Folds with Reified Monoid+ , ifoldMapBy+ , ifoldMapByOf ) where import Control.Applicative@@ -79,8 +78,8 @@ import Control.Monad (void, liftM) import Control.Monad.Trans.State.Lazy as Lazy import Control.Lens.Fold+import Control.Lens.Getter import Control.Lens.Internal.Fold-import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Internal.Level import Control.Lens.Internal.Magma@@ -88,12 +87,11 @@ import Control.Lens.Traversal import Control.Lens.Type import Data.Foldable-import Data.Functor.Contravariant-import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable import Data.HashMap.Lazy as HashMap import Data.IntMap as IntMap+import Data.List.NonEmpty as NonEmpty import Data.Map as Map import Data.Monoid import Data.Profunctor.Unsafe@@ -120,7 +118,7 @@ -- -- Mnemonically, the @>@ points to the indexing we want to preserve. ----- This is the same as @('.')@. +-- This is the same as @('.')@. -- -- @f '.' g@ (and @f '.>' g@) gives you the index of @g@ unless @g@ is index-preserving, like a -- 'Prism', 'Iso' or 'Equality', in which case it'll pass through the index of @f@.@@ -153,13 +151,13 @@ -- -- The result is only valid to compose in a 'Traversal', if you don't edit the -- index as edits to the index have no effect.-withIndex :: (Indexable i p, Functor f) => Overloading p (Indexed i) f s t (i, s) (j, t)+withIndex :: (Indexable i p, Functor f) => Optical p (Indexed i) f s t (i, s) (j, t) withIndex f = Indexed $ \i a -> snd <$> indexed f i (i, a) {-# INLINE withIndex #-} -- | When composed with an 'IndexedFold' or 'IndexedTraversal' this yields an -- ('Indexed') 'Fold' of the indices.-asIndex :: (Indexable i p, Contravariant f, Functor f) => Overloading' p (Indexed i) f s i+asIndex :: (Indexable i p, Contravariant f, Functor f) => Optical' p (Indexed i) f s i asIndex f = Indexed $ \i _ -> coerce (indexed f i i) {-# INLINE asIndex #-} @@ -175,7 +173,7 @@ -- -- >>> over (traversed.indices (>0)) Prelude.reverse $ ["He","was","stressed","o_O"] -- ["He","saw","desserts","O_o"]-indices :: (Indexable i p, Applicative f) => (i -> Bool) -> Overloading' p (Indexed i) f a a+indices :: (Indexable i p, Applicative f) => (i -> Bool) -> Optical' p (Indexed i) f a a indices p f = Indexed $ \i a -> if p i then indexed f i a else pure a {-# INLINE indices #-} @@ -183,7 +181,7 @@ -- -- >>> ["hello","the","world","!!!"]^?traversed.index 2 -- Just "world"-index :: (Indexable i p, Eq i, Applicative f) => i -> Overloading' p (Indexed i) f a a+index :: (Indexable i p, Eq i, Applicative f) => i -> Optical' p (Indexed i) f a a index j f = Indexed $ \i a -> if j == i then indexed f i a else pure a {-# INLINE index #-} @@ -203,7 +201,7 @@ class Functor f => FunctorWithIndex i f | f -> i where -- | Map with access to the index. imap :: (i -> a -> b) -> f a -> f b-#ifdef MPTC_DEFAULTS+#ifndef HLINT default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b imap = iover itraversed {-# INLINE imap #-}@@ -212,7 +210,7 @@ -- | The 'IndexedSetter' for a 'FunctorWithIndex'. -- -- If you don't need access to the index, then 'mapped' is more flexible in what it accepts.- imapped :: FunctorWithIndex i f => IndexedSetter i (f a) (f b) a b+ imapped :: IndexedSetter i (f a) (f b) a b imapped = conjoined mapped (isets imap) {-# INLINE imapped #-} @@ -231,7 +229,7 @@ -- 'foldMap' ≡ 'ifoldMap' '.' 'const' -- @ ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m-#ifdef MPTC_DEFAULTS+#ifndef HLINT default ifoldMap :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m ifoldMap = ifoldMapOf itraversed {-# INLINE ifoldMap #-}@@ -288,13 +286,6 @@ where f' i x k z = k $! f i z x {-# INLINE ifoldl' #-} --- | 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 => (s -> f a) -> IndexedFold i s a-ifolding sfa iagb = coerce . itraverse_ (indexed iagb) . sfa-{-# INLINE ifolding #-}- -- | Return whether or not any element in a container satisfies a predicate, with access to the index @i@. -- -- When you don't need access to the index then 'any' is more flexible in what it accepts.@@ -317,6 +308,27 @@ iall f = getAll #. ifoldMap (\i -> All #. f i) {-# INLINE iall #-} +-- | Return whether or not none of the elements in a container satisfy a predicate, with access to the index @i@.+--+-- When you don't need access to the index then 'none' is more flexible in what it accepts.+--+-- @+-- 'none' ≡ 'inone' '.' 'const'+-- 'inone' f ≡ 'not' '.' 'iany' f+-- @+inone :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool+inone f = not . iany f+{-# INLINE inone #-}++-- | Determines whether no elements of the structure satisfy the predicate.+--+-- @+-- 'none' f ≡ 'not' '.' 'any' f+-- @+none :: Foldable f => (a -> Bool) -> f a -> Bool+none f = not . Data.Foldable.any f+{-# INLINE none #-}+ -- | Traverse elements with access to the index @i@, discarding the results. -- -- When you don't need access to the index then 'traverse_' is more flexible in what it accepts.@@ -445,7 +457,7 @@ class (FunctorWithIndex i t, FoldableWithIndex i t, Traversable t) => TraversableWithIndex i t | t -> i where -- | Traverse an indexed container. itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b)-#ifdef MPTC_DEFAULTS+#ifndef HLINT default itraverse :: Applicative f => (Int -> a -> f b) -> t a -> f (t b) itraverse = traversed .# Indexed {-# INLINE itraverse #-}@@ -566,16 +578,18 @@ {-# INLINE itraverse #-} -- | The position in the list is available as the index.-instance FunctorWithIndex Int [] where- imap = iover itraversed- {-# INLINE imap #-}-instance FoldableWithIndex Int [] where- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-}+instance FunctorWithIndex Int []+instance FoldableWithIndex Int [] instance TraversableWithIndex Int [] where itraverse = itraverseOf traversed {-# INLINE itraverse #-} +instance FunctorWithIndex Int NonEmpty+instance FoldableWithIndex Int NonEmpty+instance TraversableWithIndex Int NonEmpty where+ itraverse = itraverseOf traversed+ {-# INLINE itraverse #-}+ instance FunctorWithIndex () Maybe where imap f = fmap (f ()) {-# INLINE imap #-}@@ -587,12 +601,8 @@ {-# INLINE itraverse #-} -- | The position in the 'Seq' is available as the index.-instance FunctorWithIndex Int Seq where- imap = iover itraversed- {-# INLINE imap #-}-instance FoldableWithIndex Int Seq where- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-}+instance FunctorWithIndex Int Seq+instance FoldableWithIndex Int Seq instance TraversableWithIndex Int Seq where itraverse = itraverseOf traversed {-# INLINE itraverse #-}@@ -601,8 +611,6 @@ imap = V.imap {-# INLINE imap #-} instance FoldableWithIndex Int Vector where- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-} ifoldr = V.ifoldr {-# INLINE ifoldr #-} ifoldl = V.ifoldl . flip@@ -615,12 +623,8 @@ itraverse f = sequenceA . V.imap f {-# INLINE itraverse #-} -instance FunctorWithIndex Int IntMap where- imap = iover itraversed- {-# INLINE imap #-}-instance FoldableWithIndex Int IntMap where- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-}+instance FunctorWithIndex Int IntMap+instance FoldableWithIndex Int IntMap instance TraversableWithIndex Int IntMap where #if MIN_VERSION_containers(0,5,0) itraverse = IntMap.traverseWithKey@@ -629,12 +633,8 @@ #endif {-# INLINE itraverse #-} -instance FunctorWithIndex k (Map k) where- imap = iover itraversed- {-# INLINE imap #-}-instance FoldableWithIndex k (Map k) where- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-}+instance FunctorWithIndex k (Map k)+instance FoldableWithIndex k (Map k) instance TraversableWithIndex k (Map k) where #if MIN_VERSION_containers(0,5,0) itraverse = Map.traverseWithKey@@ -643,12 +643,8 @@ #endif {-# INLINE itraverse #-} -instance (Eq k, Hashable k) => FunctorWithIndex k (HashMap k) where- imap = iover itraversed- {-# INLINE imap #-}-instance (Eq k, Hashable k) => FoldableWithIndex k (HashMap k) where- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-}+instance (Eq k, Hashable k) => FunctorWithIndex k (HashMap k)+instance (Eq k, Hashable k) => FoldableWithIndex k (HashMap k) instance (Eq k, Hashable k) => TraversableWithIndex k (HashMap k) where itraverse = HashMap.traverseWithKey {-# INLINE itraverse #-}@@ -707,3 +703,12 @@ skip _ = () {-# INLINE skip #-} +-------------------------------------------------------------------------------+-- Indexed Folds with Reified Monoid+-------------------------------------------------------------------------------++ifoldMapBy :: FoldableWithIndex i t => (r -> r -> r) -> r -> (i -> a -> r) -> t a -> r+ifoldMapBy f z g = reifyFold f z (ifoldMap (\i a -> M (g i a)))++ifoldMapByOf :: (forall s. IndexedGetting i (M r s) t a) -> (r -> r -> r) -> r -> (i -> a -> r) -> t -> r+ifoldMapByOf l f z g = reifyFold f z (ifoldMapOf l (\i a -> M (g i a)))
src/Control/Lens/Internal.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Control/Lens/Internal/Action.hs view
@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Action--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -27,8 +27,9 @@ import Control.Applicative import Control.Applicative.Backwards-import Control.Lens.Internal.Getter+import Control.Lens.Internal.Indexed import Control.Monad+import Control.Monad.Reader import Data.Functor.Bind import Data.Functor.Contravariant import Data.Functor.Identity@@ -52,11 +53,15 @@ ineffective = liftM Dual . ineffective . forwards {-# INLINE ineffective #-} -instance Effective Identity r (Accessor r) where- effective = Accessor #. runIdentity+instance Effective Identity r (Const r) where+ effective = Const #. runIdentity {-# INLINE effective #-}- ineffective = Identity #. runAccessor+ ineffective = Identity #. getConst {-# INLINE ineffective #-}++instance Effective m r f => Effective (ReaderT Int m) r (Indexing f) where+ effective m = Indexing (\i -> (i+1, effective (runReaderT m i)))+ ineffective i = ReaderT (ineffective . snd . runIndexing i) ------------------------------------------------------------------------------ -- Effect
src/Control/Lens/Internal/Bazaar.hs view
@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Bazaar--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -21,6 +21,9 @@ ( Bizarre(..) , Bazaar(..), Bazaar' , BazaarT(..), BazaarT'+ , Bizarre1(..)+ , Bazaar1(..), Bazaar1'+ , BazaarT1(..), BazaarT1' ) where import Control.Applicative@@ -33,6 +36,7 @@ import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Identity+import Data.Semigroup import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe@@ -180,3 +184,147 @@ instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where contramap _ = (<$) (error "contramap: BazaarT") {-# INLINE contramap #-}++instance Contravariant g => Semigroup (BazaarT p g a b t) where+ BazaarT a <> BazaarT b = BazaarT $ \f -> a f <* b f+ {-# INLINE (<>) #-}++instance Contravariant g => Monoid (BazaarT p g a b t) where+ mempty = BazaarT $ \_ -> pure (error "mempty: BazaarT")+ {-# INLINE mempty #-}+ BazaarT a `mappend` BazaarT b = BazaarT $ \f -> a f <* b f+ {-# INLINE mappend #-}+++------------------------------------------------------------------------------+-- Bizarre1+------------------------------------------------------------------------------++class Profunctor p => Bizarre1 p w | w -> p where+ bazaar1 :: Apply f => p a (f b) -> w a b t -> f t++------------------------------------------------------------------------------+-- Bazaar1+------------------------------------------------------------------------------++-- | This is used to characterize a 'Control.Lens.Traversal.Traversal'.+--+-- a.k.a. indexed Cartesian store comonad, indexed Kleene store comonad, or an indexed 'FunList'.+--+-- <http://twanvl.nl/blog/haskell/non-regular1>+--+-- A 'Bazaar1' is like a 'Control.Lens.Traversal.Traversal' that has already been applied to some structure.+--+-- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to+-- @t@, a @'Bazaar1' a b t@ holds @N@ @a@s and a function from @N@+-- @b@s to @t@, (where @N@ might be infinite).+--+-- Mnemonically, a 'Bazaar1' holds many stores and you can easily add more.+--+-- This is a final encoding of 'Bazaar1'.+newtype Bazaar1 p a b t = Bazaar1 { runBazaar1 :: forall f. Apply f => p a (f b) -> f t }++-- | This alias is helpful when it comes to reducing repetition in type signatures.+--+-- @+-- type 'Bazaar1'' p a t = 'Bazaar1' p a a t+-- @+type Bazaar1' p a = Bazaar1 p a a++instance IndexedFunctor (Bazaar1 p) where+ ifmap f (Bazaar1 k) = Bazaar1 (fmap f . k)+ {-# INLINE ifmap #-}++instance Conjoined p => IndexedComonad (Bazaar1 p) where+ iextract (Bazaar1 m) = runIdentity $ m (arr Identity)+ {-# INLINE iextract #-}+ iduplicate (Bazaar1 m) = getCompose $ m (Compose #. distrib sell . sell)+ {-# INLINE iduplicate #-}++instance Corepresentable p => Sellable p (Bazaar1 p) where+ sell = cotabulate $ \ w -> Bazaar1 $ tabulate $ \k -> pure (corep k w)+ {-# INLINE sell #-}++instance Profunctor p => Bizarre1 p (Bazaar1 p) where+ bazaar1 g (Bazaar1 f) = f g+ {-# INLINE bazaar1 #-}++instance Functor (Bazaar1 p a b) where+ fmap = ifmap+ {-# INLINE fmap #-}++instance Apply (Bazaar1 p a b) where+ Bazaar1 mf <.> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb+ {-# INLINE (<.>) #-}++instance (a ~ b, Conjoined p) => Comonad (Bazaar1 p a b) where+ extract = iextract+ {-# INLINE extract #-}+ duplicate = iduplicate+ {-# INLINE duplicate #-}++instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where+ Bazaar1 mf <@> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb+ {-# INLINE (<@>) #-}++------------------------------------------------------------------------------+-- BazaarT1+------------------------------------------------------------------------------++-- | 'BazaarT1' is like 'Bazaar1', except that it provides a questionable 'Contravariant' instance+-- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions.+--+-- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there+-- must be a better way!+newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t }++-- | This alias is helpful when it comes to reducing repetition in type signatures.+--+-- @+-- type 'BazaarT1'' p g a t = 'BazaarT1' p g a a t+-- @+type BazaarT1' p g a = BazaarT1 p g a a++instance IndexedFunctor (BazaarT1 p g) where+ ifmap f (BazaarT1 k) = BazaarT1 (fmap f . k)+ {-# INLINE ifmap #-}++instance Conjoined p => IndexedComonad (BazaarT1 p g) where+ iextract (BazaarT1 m) = runIdentity $ m (arr Identity)+ {-# INLINE iextract #-}+ iduplicate (BazaarT1 m) = getCompose $ m (Compose #. distrib sell . sell)+ {-# INLINE iduplicate #-}++instance Corepresentable p => Sellable p (BazaarT1 p g) where+ sell = cotabulate $ \ w -> BazaarT1 (`corep` w)+ {-# INLINE sell #-}++instance Profunctor p => Bizarre1 p (BazaarT1 p g) where+ bazaar1 g (BazaarT1 f) = f g+ {-# INLINE bazaar1 #-}++instance Functor (BazaarT1 p g a b) where+ fmap = ifmap+ {-# INLINE fmap #-}++instance Apply (BazaarT1 p g a b) where+ BazaarT1 mf <.> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb+ {-# INLINE (<.>) #-}++instance (a ~ b, Conjoined p) => Comonad (BazaarT1 p g a b) where+ extract = iextract+ {-# INLINE extract #-}+ duplicate = iduplicate+ {-# INLINE duplicate #-}++instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where+ BazaarT1 mf <@> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb+ {-# INLINE (<@>) #-}++instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where+ contramap _ = (<$) (error "contramap: BazaarT1")+ {-# INLINE contramap #-}++instance Contravariant g => Semigroup (BazaarT1 p g a b t) where+ BazaarT1 a <> BazaarT1 b = BazaarT1 $ \f -> a f <. b f+ {-# INLINE (<>) #-}
src/Control/Lens/Internal/ByteString.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Control/Lens/Internal/Context.hs view
@@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Context--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -84,7 +84,7 @@ -- IndexedComonadStore ------------------------------------------------------------------------------ --- | This is an indexed analogue to 'ComonadStore' for when you are working with an +-- | This is an indexed analogue to 'ComonadStore' for when you are working with an -- 'IndexedComonad'. class IndexedComonad w => IndexedComonadStore w where -- | This is the generalization of 'pos' to an indexed comonad store.
src/Control/Lens/Internal/Deque.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Deque--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -26,11 +26,11 @@ ) where import Control.Applicative-import Control.Lens.Combinators import Control.Lens.Cons import Control.Lens.Fold import Control.Lens.Indexed hiding ((<.>)) import Control.Lens.Iso+import Control.Lens.Lens import Control.Lens.Prism import Control.Monad import Data.Foldable as Foldable@@ -186,7 +186,7 @@ | otherwise = BD lf f lr r {-# INLINE check #-} -instance (Choice p, Applicative f) => Cons p f (Deque a) (Deque b) a b where+instance Cons (Deque a) (Deque b) a b where _Cons = prism (\(x,BD lf f lr r) -> check (lf + 1) (x : f) lr r) $ \ (BD lf f lr r) -> if lf + lr == 0 then Left empty@@ -195,7 +195,7 @@ (x:xs) -> (x, check (lf - 1) xs lr r) {-# INLINE _Cons #-} -instance (Choice p, Applicative f) => Snoc p f (Deque a) (Deque b) a b where+instance Snoc (Deque a) (Deque b) a b where _Snoc = prism (\(BD lf f lr r,x) -> check lf f (lr + 1) (x : r)) $ \ (BD lf f lr r) -> if lf + lr == 0 then Left empty
src/Control/Lens/Internal/Exception.hs view
@@ -10,10 +10,14 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PolyKinds #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Exception--- Copyright : (C) 2013 Edward Kmett+-- Copyright : (C) 2013-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -30,19 +34,21 @@ import Control.Exception as Exception import Control.Lens.Fold import Control.Lens.Getter-import Control.Monad.CatchIO as CatchIO-import Data.IORef+import Control.Lens.Internal.Reflection+import Control.Monad.Catch as Catch import Data.Monoid import Data.Proxy-import Data.Reflection import Data.Typeable-import System.IO.Unsafe +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+type Typeable1 = Typeable+#endif+ ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------ --- | Both @MonadCatchIO-transformers@ and "Control.Exception" provide a 'Handler' type.+-- | Both @exceptions@ and "Control.Exception" provide a 'Handler' type. -- -- This lets us write combinators to build handlers that are agnostic about the choice of -- which of these they use.@@ -65,14 +71,14 @@ -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r -- @ --- -- and with the 'CatchIO.Handler' type provided by @Control.Monad.CatchIO@:+ -- and with the 'Catch.Handler' type provided by @Control.Monad.Catch@: -- -- @- -- 'handler' :: 'Getter' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r- -- 'handler' :: 'Fold' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r- -- 'handler' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r- -- 'handler' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r- -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r+ -- 'handler' :: 'Getter' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r+ -- 'handler' :: 'Fold' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r+ -- 'handler' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r+ -- 'handler' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r+ -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r -- @ -- -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@:@@ -84,7 +90,7 @@ -- 'handler' :: 'Control.Lens.Lens.Lens'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler' :: 'Control.Lens.Traversal.Traversal'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- @- handler :: Getting (First a) e a -> (a -> m r) -> h r+ handler :: Typeable a => Getting (First a) e a -> (a -> m r) -> h r -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Prism.Prism' (or any 'Getter', really). -- that ignores its input and just recovers with the stated monadic action.@@ -105,14 +111,14 @@ -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r -- @ --- -- and with the 'CatchIO.Handler' type provided by @Control.Monad.CatchIO@:+ -- and with the 'Catch.Handler' type provided by @Control.Monad.Catch@: -- -- @- -- 'handler_' :: 'Getter' 'SomeException' a -> m r -> 'CatchIO.Handler' m r- -- 'handler_' :: 'Fold' 'SomeException' a -> m r -> 'CatchIO.Handler' m r- -- 'handler_' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> m r -> 'CatchIO.Handler' m r- -- 'handler_' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> m r -> 'CatchIO.Handler' m r- -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> m r -> 'CatchIO.Handler' m r+ -- 'handler_' :: 'Getter' 'SomeException' a -> m r -> 'Catch.Handler' m r+ -- 'handler_' :: 'Fold' 'SomeException' a -> m r -> 'Catch.Handler' m r+ -- 'handler_' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> m r -> 'Catch.Handler' m r+ -- 'handler_' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> m r -> 'Catch.Handler' m r+ -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> m r -> 'Catch.Handler' m r -- @ -- -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@:@@ -124,21 +130,21 @@ -- 'handler_' :: 'Control.Lens.Lens.Lens'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- @- handler_ :: Getting (First a) e a -> m r -> h r+ handler_ :: Typeable a => Getting (First a) e a -> m r -> h r handler_ l = handler l . const {-# INLINE handler_ #-} instance Handleable SomeException IO Exception.Handler where handler = handlerIO -instance Handleable SomeException m (CatchIO.Handler m) where+instance Typeable1 m => Handleable SomeException m (Catch.Handler m) where handler = handlerCatchIO -handlerIO :: forall a r. Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r-handlerIO l f = reify (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a)+handlerIO :: forall a r. Typeable a => Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r+handlerIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a) -handlerCatchIO :: forall m a r. Getting (First a) SomeException a -> (a -> m r) -> CatchIO.Handler m r-handlerCatchIO l f = reify (preview l) $ \ (_ :: Proxy s) -> CatchIO.Handler (\(Handling a :: Handling a s m) -> f a)+handlerCatchIO :: forall m a r. (Typeable a, Typeable1 m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r+handlerCatchIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Catch.Handler (\(Handling a :: Handling a s m) -> f a) ------------------------------------------------------------------------------ -- Helpers@@ -149,30 +155,41 @@ instance Exception HandlingException +{- -- | This supplies a globally unique set of IDs so we can hack around the default use of 'cast' in 'SomeException' -- if someone, somehow, somewhere decides to reach in and catch and rethrow a @Handling@ 'Exception' by existentially -- opening a 'Handler' that uses it. supply :: IORef Int supply = unsafePerformIO $ newIORef 0 {-# NOINLINE supply #-}+-} -- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does. newtype Handling a s (m :: * -> *) = Handling a-+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+ deriving Typeable+#else -- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap. -- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep.-instance Typeable (Handling a s m) where- typeOf _ = unsafePerformIO $ do- i <- atomicModifyIORef supply $ \a -> let a' = a + 1 in a' `seq` (a', a)- return $ mkTyConApp (mkTyCon3 "lens" "Control.Lens.Internal.Exception" ("Handling" ++ show i)) []+instance (Typeable a, Typeable s, Typeable1 m) => Typeable (Handling a s m) where+ typeOf _ = mkTyConApp handlingTyCon [typeOf (undefined :: a), typeOf (undefined :: s), typeOf1 (undefined :: m a)] {-# INLINE typeOf #-} +handlingTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+handlingTyCon = mkTyCon3 "lens" "Control.Lens.Internal.Exception" "Handling"+#else+handlingTyCon = mkTyCon "Control.Lns.Internal.Exception.Handling"+#endif+{-# NOINLINE handlingTyCon #-}+#endif+ -- The @Handling@ wrapper is uninteresting, and should never be thrown, so you won't get much benefit here. instance Show (Handling a s m) where showsPrec d _ = showParen (d > 10) $ showString "Handling ..." {-# INLINE showsPrec #-} -instance Reifies s (SomeException -> Maybe a) => Exception (Handling a s m) where+instance (Reifies s (SomeException -> Maybe a), Typeable a, Typeable1 m, Typeable s) => Exception (Handling a s m) where toException _ = SomeException HandlingException {-# INLINE toException #-} fromException = fmap Handling . reflect (Proxy :: Proxy s)
src/Control/Lens/Internal/Fold.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Fold--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -22,6 +25,8 @@ , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost+ , ReifiedMonoid(..), M(..)+ , reifyFold ) where import Control.Applicative@@ -30,7 +35,10 @@ import Data.Functor.Contravariant import Data.Maybe import Data.Semigroup hiding (Min, getMin, Max, getMax)+import Data.Reflection +{-# ANN module "HLint: ignore Avoid lambda" #-}+ ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------@@ -201,3 +209,24 @@ getRightmost RPure = Nothing getRightmost (RLeaf a) = Just a getRightmost (RStep x) = getRightmost x++------------------------------------------------------------------------------+-- Folding with Reified Monoid+------------------------------------------------------------------------------++data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a }++instance Reifies s (ReifiedMonoid a) => Monoid (M a s) where+ mappend (M x) (M y) = reflectResult (\m -> M (reifiedMappend m x y))+ mempty = reflectResult (\m -> M (reifiedMempty m ))++reflectResult :: Reifies s a => (a -> f s) -> f s+reflectResult f = let r = f (reflect r) in r++data M a s = M a++unM :: M a s -> proxy s -> a+unM (M a) _ = a++reifyFold :: (a -> a -> a) -> a -> (forall s. Reifies s (ReifiedMonoid a) => t -> M a s) -> t -> a+reifyFold f z m xs = reify (ReifiedMonoid f z) (unM (m xs))
src/Control/Lens/Internal/Getter.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Getter--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -17,13 +19,20 @@ -- ** Getters , coerce , noEffect- , Accessor(..)+ , AlongsideLeft(..)+ , AlongsideRight(..) ) where import Control.Applicative-import Data.Functor.Apply+import Control.Lens.Internal.Action+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Foldable import Data.Functor.Contravariant-import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Traversable import Data.Void -- | This class is provided mostly for backwards compatibility with lens 3.8,@@ -53,32 +62,96 @@ noEffect = coerce $ pure () {-# INLINE noEffect #-} ----------------------------------------------------------------------------------- Accessors--------------------------------------------------------------------------------+newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) } --- | Used instead of 'Const' to report------ @No instance for ('Control.Lens.Setter.Internal.Settable' 'Accessor')@------ when the user attempts to misuse a 'Control.Lens.Setter.Setter' as a--- 'Control.Lens.Getter.Getter', rather than a monolithic unification error.-newtype Accessor r a = Accessor { runAccessor :: r }+deriving instance Show (f (a, b)) => Show (AlongsideLeft f b a)+deriving instance Read (f (a, b)) => Read (AlongsideLeft f b a) -instance Functor (Accessor r) where- fmap _ (Accessor m) = Accessor m+instance Functor f => Functor (AlongsideLeft f b) where+ fmap f = AlongsideLeft . fmap (first f) . getAlongsideLeft {-# INLINE fmap #-} -instance Contravariant (Accessor r) where- contramap _ (Accessor m) = Accessor m+instance Contravariant f => Contravariant (AlongsideLeft f b) where+ contramap f = AlongsideLeft . contramap (first f) . getAlongsideLeft {-# INLINE contramap #-} -instance Semigroup r => Apply (Accessor r) where- Accessor a <.> Accessor b = Accessor (a <> b)- {-# INLINE (<.>) #-}+instance Foldable f => Foldable (AlongsideLeft f b) where+ foldMap f = foldMap (f . fst) . getAlongsideLeft+ {-# INLINE foldMap #-} -instance Monoid r => Applicative (Accessor r) where- pure _ = Accessor mempty- {-# INLINE pure #-}- Accessor a <*> Accessor b = Accessor (mappend a b)- {-# INLINE (<*>) #-}+instance Traversable f => Traversable (AlongsideLeft f b) where+ traverse f (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse f pure) as+ {-# INLINE traverse #-}++instance Foldable1 f => Foldable1 (AlongsideLeft f b) where+ foldMap1 f = foldMap1 (f . fst) . getAlongsideLeft+ {-# INLINE foldMap1 #-}++instance Traversable1 f => Traversable1 (AlongsideLeft f b) where+ traverse1 f (AlongsideLeft as) = AlongsideLeft <$> traverse1 (\(a,b) -> flip (,) b <$> f a) as+ {-# INLINE traverse1 #-}++instance Functor f => Bifunctor (AlongsideLeft f) where+ bimap f g = AlongsideLeft . fmap (bimap g f) . getAlongsideLeft+ {-# INLINE bimap #-}++instance Foldable f => Bifoldable (AlongsideLeft f) where+ bifoldMap f g = foldMap (bifoldMap g f) . getAlongsideLeft+ {-# INLINE bifoldMap #-}++instance Traversable f => Bitraversable (AlongsideLeft f) where+ bitraverse f g (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse g f) as+ {-# INLINE bitraverse #-}++instance Effective m r f => Effective m r (AlongsideLeft f b) where+ effective = AlongsideLeft . effective+ {-# INLINE effective #-}+ ineffective = ineffective . getAlongsideLeft+ {-# INLINE ineffective #-}++newtype AlongsideRight f a b = AlongsideRight { getAlongsideRight :: f (a, b) }++deriving instance Show (f (a, b)) => Show (AlongsideRight f a b)+deriving instance Read (f (a, b)) => Read (AlongsideRight f a b)++instance Functor f => Functor (AlongsideRight f a) where+ fmap f (AlongsideRight x) = AlongsideRight (fmap (second f) x)+ {-# INLINE fmap #-}++instance Contravariant f => Contravariant (AlongsideRight f a) where+ contramap f (AlongsideRight x) = AlongsideRight (contramap (second f) x)+ {-# INLINE contramap #-}++instance Foldable f => Foldable (AlongsideRight f a) where+ foldMap f = foldMap (f . snd) . getAlongsideRight+ {-# INLINE foldMap #-}++instance Traversable f => Traversable (AlongsideRight f a) where+ traverse f (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse pure f) as+ {-# INLINE traverse #-}++instance Foldable1 f => Foldable1 (AlongsideRight f a) where+ foldMap1 f = foldMap1 (f . snd) . getAlongsideRight+ {-# INLINE foldMap1 #-}++instance Traversable1 f => Traversable1 (AlongsideRight f a) where+ traverse1 f (AlongsideRight as) = AlongsideRight <$> traverse1 (\(a,b) -> (,) a <$> f b) as+ {-# INLINE traverse1 #-}++instance Functor f => Bifunctor (AlongsideRight f) where+ bimap f g = AlongsideRight . fmap (bimap f g) . getAlongsideRight+ {-# INLINE bimap #-}++instance Foldable f => Bifoldable (AlongsideRight f) where+ bifoldMap f g = foldMap (bifoldMap f g) . getAlongsideRight+ {-# INLINE bifoldMap #-}++instance Traversable f => Bitraversable (AlongsideRight f) where+ bitraverse f g (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse f g) as+ {-# INLINE bitraverse #-}++instance Effective m r f => Effective m r (AlongsideRight f b) where+ effective = AlongsideRight . effective+ {-# INLINE effective #-}+ ineffective = ineffective . getAlongsideRight+ {-# INLINE ineffective #-}
src/Control/Lens/Internal/Indexed.hs view
@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Indexed--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -263,7 +263,7 @@ -- 'indexing' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int' s a -- @ ----- @'indexing' :: 'Indexable' 'Int' p => 'Control.Lens.Type.LensLike' ('Indexing' f) s t a b -> 'Control.Lens.Type.Overloading' p (->) f s t a b@+-- @'indexing' :: 'Indexable' 'Int' p => 'Control.Lens.Type.LensLike' ('Indexing' f) s t a b -> 'Control.Lens.Type.Optical' p (->) f s t a b@ indexing :: Indexable Int p => ((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t indexing l iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 {-# INLINE indexing #-}@@ -314,7 +314,7 @@ -- 'indexing64' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int64' s a -- @ ----- @'indexing64' :: 'Indexable' 'Int64' p => 'Control.Lens.Type.LensLike' ('Indexing64' f) s t a b -> 'Control.Lens.Type.Overloading' p (->) f s t a b@+-- @'indexing64' :: 'Indexable' 'Int64' p => 'Control.Lens.Type.LensLike' ('Indexing64' f) s t a b -> 'Control.Lens.Type.Over' p f s t a b@ indexing64 :: Indexable Int64 p => ((a -> Indexing64 f b) -> s -> Indexing64 f t) -> p a (f b) -> s -> f t indexing64 l iafb s = snd $ runIndexing64 (l (\a -> Indexing64 (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 {-# INLINE indexing64 #-}
src/Control/Lens/Internal/Instances.hs view
@@ -4,33 +4,24 @@ #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif--#ifndef MIN_VERSION_semigroupoids-#define MIN_VERSION_semigroupoids(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Instances--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental -- Portability : non-portable -- -- This module includes orphan instances for @(,)@, 'Either' and 'Const' that--- should be supplied by base. These have moved to @semigroupoids@ as of 4.2.+-- should be supplied by base. ---------------------------------------------------------------------------- module Control.Lens.Internal.Instances () where -import Data.Traversable.Instances ()--#if !(MIN_VERSION_semigroupoids(0,4,2))- import Control.Applicative import Data.Semigroup.Foldable import Data.Semigroup.Traversable - #if !(MIN_VERSION_base(4,7,0)) import Data.Monoid import Data.Foldable@@ -69,4 +60,3 @@ instance Traversable1 ((,) b) where traverse1 f (b, a) = (,) b <$> f a -#endif
src/Control/Lens/Internal/Iso.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Iso--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Control/Lens/Internal/Level.hs view
@@ -5,14 +5,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Level--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Control/Lens/Internal/Magma.hs view
@@ -7,14 +7,13 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Control/Lens/Internal/Prism.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Prism--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
+ src/Control/Lens/Internal/Reflection.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-cse #-}+{-# OPTIONS_GHC -fno-full-laziness #-}+{-# OPTIONS_GHC -fno-float-in #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -pgmPcpphs -optP--cpp -optP-ansi #-}+----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.Reflection+-- Copyright : 2009-2014 Edward Kmett,+-- 2012 Elliott Hird,+-- 2004 Oleg Kiselyov and Chung-chieh Shan+-- License : BSD3+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Reifies arbitrary terms at the type level. Based on the Functional+-- Pearl: Implicit Configurations paper by Oleg Kiselyov and+-- Chung-chieh Shan.+--+-- <http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf>+--+-- The approach from the paper was modified to work with Data.Proxy+-- and streamline the API by Edward Kmett and Elliott Hird.+--+-- Usage comes down to two combinators, 'reify' and 'reflect'.+--+-- >>> reify 6 (\p -> reflect p + reflect p)+-- 12+--+-- The argument passed along by reify is just a @data 'Proxy' t =+-- Proxy@, so all of the information needed to reconstruct your value+-- has been moved to the type level. This enables it to be used when+-- constructing instances (see @examples/Monoid.hs@).+--+-- This version is based on the \"slow\" path from the @reflection@ package,+-- but modified to work with the same 'Reifies' class as is provided by the \"fast\"+-- path, and to make sure the parameter is 'Typeable'.+--+-- This is necessary to work around the changes to @Data.Typeable@ in GHC HEAD.+-------------------------------------------------------------------------------++module Control.Lens.Internal.Reflection+ (+ Reifies(..)+ , reifyTypeable+ ) where++import Foreign.Ptr+import Foreign.StablePtr+import System.IO.Unsafe+import Control.Applicative+import Data.Proxy+import Data.Bits+import Data.Word+import Data.Typeable+import Data.Reflection++{-# ANN module "HLint: ignore Avoid lambda" #-}++class Typeable s => B s where+ reflectByte :: proxy s -> IntPtr++#define CAT(a, b) a##b++#define BYTES(GO) \+ GO(0) GO(1) GO(2) GO(3) GO(4) GO(5) GO(6) GO(7) GO(8) GO(9) GO(10) GO(11) \+ GO(12) GO(13) GO(14) GO(15) GO(16) GO(17) GO(18) GO(19) GO(20) GO(21) GO(22) \+ GO(23) GO(24) GO(25) GO(26) GO(27) GO(28) GO(29) GO(30) GO(31) GO(32) GO(33) \+ GO(34) GO(35) GO(36) GO(37) GO(38) GO(39) GO(40) GO(41) GO(42) GO(43) GO(44) \+ GO(45) GO(46) GO(47) GO(48) GO(49) GO(50) GO(51) GO(52) GO(53) GO(54) GO(55) \+ GO(56) GO(57) GO(58) GO(59) GO(60) GO(61) GO(62) GO(63) GO(64) GO(65) GO(66) \+ GO(67) GO(68) GO(69) GO(70) GO(71) GO(72) GO(73) GO(74) GO(75) GO(76) GO(77) \+ GO(78) GO(79) GO(80) GO(81) GO(82) GO(83) GO(84) GO(85) GO(86) GO(87) GO(88) \+ GO(89) GO(90) GO(91) GO(92) GO(93) GO(94) GO(95) GO(96) GO(97) GO(98) GO(99) \+ GO(100) GO(101) GO(102) GO(103) GO(104) GO(105) GO(106) GO(107) GO(108) \+ GO(109) GO(110) GO(111) GO(112) GO(113) GO(114) GO(115) GO(116) GO(117) \+ GO(118) GO(119) GO(120) GO(121) GO(122) GO(123) GO(124) GO(125) GO(126) \+ GO(127) GO(128) GO(129) GO(130) GO(131) GO(132) GO(133) GO(134) GO(135) \+ GO(136) GO(137) GO(138) GO(139) GO(140) GO(141) GO(142) GO(143) GO(144) \+ GO(145) GO(146) GO(147) GO(148) GO(149) GO(150) GO(151) GO(152) GO(153) \+ GO(154) GO(155) GO(156) GO(157) GO(158) GO(159) GO(160) GO(161) GO(162) \+ GO(163) GO(164) GO(165) GO(166) GO(167) GO(168) GO(169) GO(170) GO(171) \+ GO(172) GO(173) GO(174) GO(175) GO(176) GO(177) GO(178) GO(179) GO(180) \+ GO(181) GO(182) GO(183) GO(184) GO(185) GO(186) GO(187) GO(188) GO(189) \+ GO(190) GO(191) GO(192) GO(193) GO(194) GO(195) GO(196) GO(197) GO(198) \+ GO(199) GO(200) GO(201) GO(202) GO(203) GO(204) GO(205) GO(206) GO(207) \+ GO(208) GO(209) GO(210) GO(211) GO(212) GO(213) GO(214) GO(215) GO(216) \+ GO(217) GO(218) GO(219) GO(220) GO(221) GO(222) GO(223) GO(224) GO(225) \+ GO(226) GO(227) GO(228) GO(229) GO(230) GO(231) GO(232) GO(233) GO(234) \+ GO(235) GO(236) GO(237) GO(238) GO(239) GO(240) GO(241) GO(242) GO(243) \+ GO(244) GO(245) GO(246) GO(247) GO(248) GO(249) GO(250) GO(251) GO(252) \+ GO(253) GO(254) GO(255)++#define GO(n) \+ newtype CAT(T,n) = CAT(T,n) CAT(T,n) deriving Typeable; \+ instance B CAT(T,n) where { \+ reflectByte _ = n \+ };+BYTES(GO)+#undef GO++impossible :: a+impossible = error "Data.Reflection.reifyByte: impossible"++reifyByte :: Word8 -> (forall s. B s => Proxy s -> r) -> r+reifyByte w k = case w of {+#define GO(n) n -> k (Proxy :: Proxy CAT(T,n));+BYTES(GO)+#undef GO+_ -> impossible+}++newtype W b0 b1 b2 b3 = W (W b0 b1 b2 b3) deriving Typeable+newtype Stable w0 w1 a = Stable (Stable w0 w1 a) deriving Typeable++stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7+ -> Proxy (Stable (W b0 b1 b2 b3) (W b4 b5 b6 b7) a)+stable _ _ _ _ _ _ _ _ = Proxy+{-# INLINE stable #-}++stablePtrToIntPtr :: StablePtr a -> IntPtr+stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr+{-# INLINE stablePtrToIntPtr #-}++intPtrToStablePtr :: IntPtr -> StablePtr a+intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr+{-# INLINE intPtrToStablePtr #-}++byte0 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b0+byte0 _ = Proxy++byte1 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b1+byte1 _ = Proxy++byte2 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b2+byte2 _ = Proxy++byte3 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b3+byte3 _ = Proxy++byte4 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b4+byte4 _ = Proxy++byte5 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b5+byte5 _ = Proxy++byte6 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b6+byte6 _ = Proxy++byte7 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b7+byte7 _ = Proxy++argument :: (p s -> r) -> Proxy s+argument _ = Proxy++instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7, w0 ~ W b0 b1 b2 b3, w1 ~ W b4 b5 b6 b7)+ => Reifies (Stable w0 w1 a) a where+ reflect = r where+ r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p+ s = argument r+ p = intPtrToStablePtr $+ reflectByte (byte0 s) .|.+ (reflectByte (byte1 s) `shiftL` 8) .|.+ (reflectByte (byte2 s) `shiftL` 16) .|.+ (reflectByte (byte3 s) `shiftL` 24) .|.+ (reflectByte (byte4 s) `shiftL` 32) .|.+ (reflectByte (byte5 s) `shiftL` 40) .|.+ (reflectByte (byte6 s) `shiftL` 48) .|.+ (reflectByte (byte7 s) `shiftL` 56)+ {-# NOINLINE reflect #-}++-- This had to be moved to the top level, due to an apparent bug in+-- the ghc inliner introduced in ghc 7.0.x+reflectBefore :: Reifies s a => (Proxy s -> b) -> proxy s -> b+reflectBefore f = const $! f Proxy+{-# NOINLINE reflectBefore #-}++-- | Reify a value at the type level in a 'Typeable'-compatible fashion, to be recovered with 'reflect'.+reifyTypeable :: Typeable a => a -> (forall s. (Typeable s, Reifies s a) => Proxy s -> r) -> r+reifyTypeable a k = unsafeDupablePerformIO $ do+ p <- newStablePtr a+ let n = stablePtrToIntPtr p+ reifyByte (fromIntegral n) (\s0 ->+ reifyByte (fromIntegral (n `shiftR` 8)) (\s1 ->+ reifyByte (fromIntegral (n `shiftR` 16)) (\s2 ->+ reifyByte (fromIntegral (n `shiftR` 24)) (\s3 ->+ reifyByte (fromIntegral (n `shiftR` 32)) (\s4 ->+ reifyByte (fromIntegral (n `shiftR` 40)) (\s5 ->+ reifyByte (fromIntegral (n `shiftR` 48)) (\s6 ->+ reifyByte (fromIntegral (n `shiftR` 56)) (\s7 ->+ reflectBefore (fmap return k) $+ stable s0 s1 s2 s3 s4 s5 s6 s7))))))))
src/Control/Lens/Internal/Review.hs view
@@ -1,17 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-#ifdef TRUSTWORTHY-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Review--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -19,32 +14,16 @@ -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Review- ( + ( -- * Internal Classes- Reviewable,+ Reviewable -- * Reviews- retagged,- Reviewed(..)+ , retagged ) where -import Control.Applicative-import Control.Comonad-import Control.Monad.Fix-import Data.Bifoldable import Data.Bifunctor-import Data.Bitraversable-import Data.Distributive-import Data.Foldable-import Data.Functor.Bind import Data.Profunctor-import Data.Profunctor.Rep-import Data.Profunctor.Unsafe-import Data.Proxy-import Data.Traversable import Data.Void-#ifndef SAFE-import Unsafe.Coerce-#endif -- | This class is provided mostly for backwards compatibility with lens 3.8, -- but it can also shorten type signatures.@@ -61,109 +40,3 @@ -- or 'Const' do for "Control.Lens.Getter" retagged :: (Profunctor p, Bifunctor p) => p a b -> p s b retagged = first absurd . lmap absurd--newtype Reviewed a b = Reviewed { runReviewed :: b }--instance Functor (Reviewed a) where- fmap bc (Reviewed b) = Reviewed (bc b)- {-# INLINE fmap #-}--instance Apply (Reviewed a) where- (<.>) a = Reviewed #. runReviewed a .# runReviewed- {-# INLINE (<.>) #-}- a <. _ = a- {-# INLINE (<.) #-}- _ .> b = b- {-# INLINE (.>) #-}--instance Applicative (Reviewed a) where- pure = Reviewed- (<*>) a = Reviewed #. runReviewed a .# runReviewed- {-# INLINE (<*>) #-}- a <* _ = a- {-# INLINE (<*) #-}- _ *> b = b- {-# INLINE (*>) #-}--instance Comonad (Reviewed a) where- extract = runReviewed- {-# INLINE extract #-}- duplicate = Reviewed- {-# INLINE duplicate #-}- extend = ( #. ) Reviewed- {-# INLINE extend #-}--instance ComonadApply (Reviewed a) where- (<@>) a = Reviewed #. runReviewed a .# runReviewed- {-# INLINE (<@>) #-}- a <@ _ = a- {-# INLINE (<@) #-}- _ @> b = b- {-# INLINE (@>) #-}--instance Bind (Reviewed a) where- Reviewed a >>- f = f a- {-# INLINE (>>-) #-}--instance Monad (Reviewed a) where- return = Reviewed- {-# INLINE return #-}- Reviewed a >>= f = f a- {-# INLINE (>>=) #-}- _ >> a = a- {-# INLINE (>>) #-}--instance MonadFix (Reviewed a) where- mfix f = a where a = f (runReviewed a)- {-# INLINE mfix #-}--instance Foldable (Reviewed a) where- foldMap f (Reviewed b) = f b- {-# INLINE foldMap #-}--instance Traversable (Reviewed a) where- traverse f (Reviewed b) = Reviewed <$> f b- {-# INLINE traverse #-}--instance Bifunctor Reviewed where- bimap _ g (Reviewed b) = Reviewed (g b)- {-# INLINE bimap #-}--instance Bifoldable Reviewed where- bifoldMap _ g (Reviewed b) = g b- {-# INLINE bifoldMap #-}--instance Bitraversable Reviewed where- bitraverse _ g (Reviewed b) = Reviewed <$> g b- {-# INLINE bitraverse #-}--instance Distributive (Reviewed a) where- distribute = Reviewed . fmap runReviewed- {-# INLINE distribute #-}--instance Profunctor Reviewed where- dimap _ f (Reviewed c) = Reviewed (f c)- {-# INLINE dimap #-}- lmap _ (Reviewed c) = Reviewed c- {-# INLINE lmap #-}- rmap = fmap- {-# INLINE rmap #-}- Reviewed b .# _ = Reviewed b- {-# INLINE ( .# ) #-}-#ifndef SAFE- ( #. ) _ = unsafeCoerce- {-# INLINE ( #. ) #-}-#endif--instance Choice Reviewed where- left' (Reviewed b) = Reviewed (Left b)- {-# INLINE left' #-}- right' (Reviewed b) = Reviewed (Right b)- {-# INLINE right' #-}--instance Corepresentable Reviewed where- type Corep Reviewed = Proxy- cotabulate f = Reviewed (f Proxy)- {-# INLINE cotabulate #-}- corep (Reviewed b) Proxy = b- {-# INLINE corep #-}
src/Control/Lens/Internal/Setter.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Setter--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -16,17 +16,12 @@ ( -- ** Setters Settable(..)- , Mutator(..) ) where import Control.Applicative import Control.Applicative.Backwards-import Control.Comonad import Data.Distributive-import Data.Foldable-import Data.Functor.Bind import Data.Functor.Compose-import Data.Functor.Extend import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Unsafe@@ -66,76 +61,3 @@ untainted = untaintedDot (untaintedDot getCompose) {-# INLINE untainted #-} --------------------------------------------------------------------------------- Mutator---------------------------------------------------------------------------------- | 'Mutator' is just a renamed 'Identity' 'Functor' to give better error--- messages when someone attempts to use a 'Control.Lens.Getter.Getter' as a 'Control.Lens.Setter.Setter'.------ Most user code will never need to see this type.-newtype Mutator a = Mutator { runMutator :: a }--instance Functor Mutator where- fmap f (Mutator a) = Mutator (f a)- {-# INLINE fmap #-}--instance Apply Mutator where- Mutator f <.> Mutator a = Mutator (f a)- {-# INLINE (<.>) #-}--instance Applicative Mutator where- pure = Mutator- {-# INLINE pure #-}- Mutator f <*> Mutator a = Mutator (f a)- {-# INLINE (<*>) #-}--instance Bind Mutator where- Mutator x >>- f = f x- {-# INLINE (>>-) #-}- join = runMutator- {-# INLINE join #-}--instance Monad Mutator where- return = Mutator- {-# INLINE return #-}- Mutator x >>= f = f x- {-# INLINE (>>=) #-}--instance Extend Mutator where- extended f w = Mutator (f w)- {-# INLINE extended #-}- duplicated = Mutator- {-# INLINE duplicated #-}--instance Comonad Mutator where- extract = runMutator- {-# INLINE extract #-}- extend f w = Mutator (f w)- {-# INLINE extend #-}- duplicate = Mutator- {-# INLINE duplicate #-}--instance ComonadApply Mutator where- Mutator f <@> Mutator a = Mutator (f a)- {-# INLINE (<@>) #-}--instance Distributive Mutator where- distribute = Mutator . fmap runMutator- {-# INLINE distribute #-}--instance Foldable Mutator where- foldMap f (Mutator a) = f a- {-# INLINE foldMap #-}--instance Traversable Mutator where- traverse f (Mutator a) = Mutator <$> f a- {-# INLINE traverse #-}--instance Settable Mutator where- untainted = runMutator- {-# INLINE untainted #-}- untaintedDot = (runMutator #.)- {-# INLINE untaintedDot #-}- taintedDot = (Mutator #.)- {-# INLINE taintedDot #-}
+ src/Control/Lens/Internal/TH.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif++#ifndef MIN_VERSION_template_haskell+#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.TH+-- Copyright : (C) 2013-2014 Edward Kmett, 2013 Eric Mertens+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+----------------------------------------------------------------------------+module Control.Lens.Internal.TH where++import Language.Haskell.TH++-- | Compatibility shim for recent changes to template haskell's 'tySynInstD'+tySynInstD' :: Name -> [TypeQ] -> TypeQ -> DecQ+#if MIN_VERSION_template_haskell(2,9,0)+tySynInstD' fam ts r = tySynInstD fam (tySynEqn ts r)+#else+tySynInstD' = tySynInstD+#endif++appsT :: TypeQ -> [TypeQ] -> TypeQ+appsT = foldl appT++appsE1 :: ExpQ -> [ExpQ] -> ExpQ+appsE1 = foldl appE++toTupleT :: [TypeQ] -> TypeQ+toTupleT [x] = x+toTupleT xs = appsT (tupleT (length xs)) xs++toTupleE :: [ExpQ] -> ExpQ+toTupleE [x] = x+toTupleE xs = tupE xs++toTupleP :: [PatQ] -> PatQ+toTupleP [x] = x+toTupleP xs = tupP xs+
+ src/Control/Lens/Internal/TupleIxedTH.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.TupleIxedTH+-- Copyright : (C) 2014 Edward Kmett+-- (C) 2012-13 Eric Mertens+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+----------------------------------------------------------------------------+module Control.Lens.Internal.TupleIxedTH+ ( makeAllTupleIxed+ ) where++import Control.Applicative+import Data.Traversable (traverse)+import Language.Haskell.TH++import Control.Lens.Internal.TH++-- This module needs to be used by Control.Lens.At which defines these names+indexN, ixValueN, ixedN, ixN :: Name+indexN = mkName "Index"+ixValueN = mkName "IxValue"+ixedN = mkName "Ixed"+ixN = mkName "ix"++-- While GHC supports tuples up to 62, it can't cope with the resulting+-- large definitions. 9-tuples should be enough for anyone.++-- This generates all of the Ixed instances for tuples up to 9.+makeAllTupleIxed :: DecsQ+makeAllTupleIxed = fmap concat (traverse makeTupleIxed [2..9])++-- type instance Index (a,..) = Int+-- type instance IxValue (a,..) = a+-- instance (a~b,a~c...) => Ixed (a,b,c..) where+-- ix i f (a,b,c..) = fmap (\x -> (a,b,c...x..)) (f z)+-- ix _ f x = pure x+makeTupleIxed :: Int -> DecsQ+makeTupleIxed n = sequence [tupleIndex n, tupleIxValue n, tupleIxed n]++-- type instance Index (a,..) = Int+tupleIndex :: Int -> DecQ+tupleIndex n = tySynInstD' indexN [fullTupleT n] [t|Int|]++-- type instance IxValue (a,..) = a+tupleIxValue :: Int -> DecQ+tupleIxValue n = tySynInstD' ixValueN [fullTupleT n] (head tupleVarTypes)++-- (a,..)+fullTupleT :: Int -> TypeQ+fullTupleT n = toTupleT (take n tupleVarTypes)++-- instance (a~b,a~c...) => Ixed (a,b,c..) where+-- ix i f (a,b,c..) = fmap (\x -> (a,b,c...x..)) (f z)+-- ix _ f x = pure x+tupleIxed :: Int -> DecQ+tupleIxed n = instanceD (cxt eqs) (conT ixedN `appT` fullTupleT n) [funD ixN clauses]+ where+ ty0:tyN = take n tupleVarTypes+ eqs = [ty0 `equalP` ty | ty <- tyN]+ clauses = map nClause [0..n-1] ++ [otherClause]++ -- ix i f (a,..) = fmap (\x->(a,..x..)) (f z)+ nClause i = do+ let iP = litP (integerL (fromIntegral i))+ f <- newName "f"+ let fP = varP f+ fE = varE f+ xs <- mapM newName (take n nameSource)+ let xsP = map varP xs+ xsE = map varE xs+ xE = varE (xs !! i)+ clause [iP, fP, toTupleP xsP]+ (normalB [| fmap (\x -> $(toTupleE (replaceAt i [|x|] xsE))) ($fE $xE) |])+ []++ -- ix _ _ x = pure x+ otherClause = do+ x <- newName "x"+ clause [wildP, wildP, varP x] (normalB [|pure $(varE x)|]) []++tupleVarTypes :: [TypeQ]+tupleVarTypes = map (varT . mkName) nameSource++-- [a,b,c,d...a1,b1,b2...a2,b2,c3...]+nameSource :: [String]+nameSource = [ a:n | n <- "" : map show [1 :: Int ..]+ , a <- ['a'..'z']+ ]++-- While this could be easily implemented as 'set . ix'+-- this local definition removes any circular dependency+-- issues.+replaceAt :: Int -> a -> [a] -> [a]+replaceAt 0 x (_:ys) = x : ys+replaceAt i x (y:ys) = y : replaceAt (i-1) x ys+replaceAt _ _ [] = error "replaceAt: index too large"
− src/Control/Lens/Internal/Zipper.hs
@@ -1,875 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ExistentialQuantification #-}-#ifdef TRUSTWORTHY-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module : Control.Lens.Internal.Zipper--- Copyright : (C) 2012-2013 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- 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.---------------------------------------------------------------------------------module Control.Lens.Internal.Zipper where--import Control.Applicative-import Control.Category ((>>>))-import Control.Monad-import Control.Lens.Getter-import Control.Lens.Indexed-import Control.Lens.Internal.Context-import Control.Lens.Internal.Indexed-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.Traversal-import Control.Lens.Type-import Data.Foldable-import Data.Functor.Apply-import Data.Maybe-import Data.Monoid-import Data.Profunctor.Unsafe---- $setup--- >>> :set -XNoOverloadedStrings--- >>> import Control.Lens--- >>> import Data.Char--#ifdef HLINT-{-# ANN module "HLint: ignore Use foldl" #-}-#endif----------------------------------------------------------------------------------- * Jacket----------------------------------------------------------------------------------- | A 'Jacket' is used to store the contents of a 'Traversal' in a way--- that we do not have to re-asocciate the elements. This enables us to--- more gracefully deal with infinite traversals.-data Jacket i a- = Ap Int -- size- Bool -- left-to-right null check- Bool -- right-to-left null check- (Last i)- (Jacket i a) -- left- (Jacket i a) -- right- | Leaf i a- | Pure- deriving Show---- | Return the number of children in a jacket-size :: Jacket i a -> Int-size (Ap s _ _ _ _ _) = s-size Leaf{} = 1-size Pure = 0-{-# INLINE size #-}---- | This is an internal function used to check from left-to-right if a 'Jacket' has any 'Leaf' nots or not.-nullLeft :: Jacket i a -> Bool-nullLeft (Ap _ nl _ _ _ _) = nl-nullLeft (Leaf _ _) = False-nullLeft Pure = True-{-# INLINE nullLeft #-}---- | This is an internal function used to check from right-to-left if a 'Jacket' has any 'Leaf' nots or not.-nullRight :: Jacket i a -> Bool-nullRight (Ap _ _ nr _ _ _) = nr-nullRight (Leaf _ _) = False-nullRight Pure = True-{-# INLINE nullRight #-}---- | This is used to extract the maximal key from a 'Jacket'. This is used by 'moveTo' and 'moveToward' to--- seek specific keys, borrowing the asympotic guarantees of the original structure in many cases!-maximal :: Jacket i a -> Last i-maximal (Ap _ _ _ li _ _) = li-maximal (Leaf i _) = Last (Just i)-maximal Pure = Last Nothing-{-# INLINE maximal #-}--instance Functor (Jacket i) where- fmap f (Ap m nl nr li l r) = Ap m nl nr li (fmap f l) (fmap f r)- fmap f (Leaf i a) = Leaf i (f a)- fmap _ Pure = Pure- {-# INLINE fmap #-}--instance Foldable (Jacket i) where- foldMap f (Ap _ _ _ _ l r) = foldMap f l `mappend` foldMap f r- foldMap f (Leaf _ a) = f a- foldMap _ Pure = mempty- {-# INLINE foldMap #-}--instance Traversable (Jacket i) where- traverse f (Ap m nl nr li l r) = Ap m nl nr li <$> traverse f l <*> traverse f r- traverse f (Leaf i a) = Leaf i <$> f a- traverse _ Pure = pure Pure- {-# INLINE traverse #-}--instance FunctorWithIndex i (Jacket i) where- imap f = go where- go (Ap m nl nr li l r) = Ap m nl nr li (go l) (go r)- go (Leaf i a) = Leaf i (f i a)- go Pure = Pure- {-# INLINE imap #-}--instance FoldableWithIndex i (Jacket i) where- ifoldMap f = go where- go (Ap _ _ _ _ l r) = go l `mappend` go r- go (Leaf i a) = f i a- go Pure = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i (Jacket i) where- itraverse f = go where- go (Ap m nl nr li l r) = Ap m nl nr li <$> go l <*> go r- go (Leaf i a) = Leaf i <$> f i a- go Pure = pure Pure- {-# INLINE itraverse #-}---- | This is an illegal 'Monoid'.-instance Monoid (Jacket i a) where- mempty = Pure- {-# INLINE mempty #-}-- mappend l r = Ap (size l + size r) (nullLeft l && nullLeft r) (nullRight r && nullRight l) (maximal l <> maximal r) l r- {-# INLINE mappend #-}---- | Construct a 'Jacket' from a 'Bazaar'-jacketIns :: Bazaar (Indexed i) a b t -> Jacket i a-jacketIns (Bazaar bz) = runAccessor $ bz $ Indexed (\i -> Accessor #. Leaf i)-{-# INLINE jacketIns #-}----------------------------------------------------------------------------------- * Flow----------------------------------------------------------------------------------- | Once we've updated a 'Zipper' we need to put the values back into the original--- shape. 'Flow' is an illegal 'Applicative' that is used to put the values back.-newtype Flow i b a = Flow { runFlow :: Jacket i b -> a }--instance Functor (Flow i b) where- fmap f (Flow g) = Flow (f . g)- {-# INLINE fmap #-}--instance Apply (Flow i b) where- (<.>) = (<*>)- {- INLINE (<.>) #-}---- | This is an illegal 'Applicative'.-instance Applicative (Flow i b) where- pure a = Flow (const a)- {-# INLINE pure #-}- Flow mf <*> Flow ma = Flow $ \ s -> case s of- Ap _ _ _ _ l r -> mf l (ma r)- _ -> mf s (ma s)- {-# INLINE (<*>) #-}---- | Given a 'Bazaar' and a 'Jacket' build from that 'Bazaar' with 'jacketIns',--- refill the 'Bazaar' with its new contents.-jacketOuts :: Bazaar (Indexed i) a b t -> Jacket j b -> t-jacketOuts bz = runFlow $ runBazaar bz $ Indexed $ \ _ _ -> Flow $ \ t -> case t of- Leaf _ a -> a- _ -> error "jacketOuts: wrong shape"-{-# INLINE jacketOuts #-}---- | This is only a valid 'Lens' if you don't change the shape of the 'Jacket'!-jacket :: AnIndexedTraversal i s t a b -> Lens s t (Jacket i a) (Jacket j b)-jacket l f s = jacketOuts bz <$> f (jacketIns bz) where- bz = l sell s-{-# INLINE jacket #-}----------------------------------------------------------------------------------- * Paths----------------------------------------------------------------------------------- | A 'Path' into a 'Jacket' that ends at a 'Leaf'.-data Path i a- = ApL Int Bool Bool (Last i) !(Path i a) !(Jacket i a)- | ApR Int Bool Bool (Last i) !(Jacket i a) !(Path i a)- | Start- deriving Show--instance Functor (Path i) where- fmap f (ApL m nl nr li p q) = ApL m nl nr li (fmap f p) (fmap f q)- fmap f (ApR m nl nr li p q) = ApR m nl nr li (fmap f p) (fmap f q)- fmap _ Start = Start- {-# INLINE fmap #-}---- | Calculate the absolute position of the 'Leaf' targeted by a 'Path'.------ This can be quite expensive for right-biased traversals such as you--- receive from a list.-offset :: Path i a -> Int-offset Start = 0-offset (ApL _ _ _ _ q _) = offset q-offset (ApR _ _ _ _ l q) = size l + offset q-{-# INLINE offset #-}---- | Return the total number of children in the 'Jacket' by walking the--- 'Path' to the root.-pathsize :: Path i a -> Int-pathsize = go 1 where- go n Start = n- go _ (ApL n _ _ _ p _) = go n p- go _ (ApR n _ _ _ _ p) = go n p-{-# INLINE pathsize #-}---- * Recursion------ For several operations, we unroll the first step of the recursion (or part--- of it) so GHC can inline better. There are two specific cases that we care--- about: The "lens case", where the entire tree is just (Leaf (Identity x)), and the--- "list case", where the traversal tree is right-biased, as in (Ap (Leaf (Identity x))--- (Ap (Leaf (Identity y)) ...)). It should be safe to delete any of these cases.---- | Reconstruct a 'Jacket' from a 'Path'.-recompress :: Path i a -> i -> a -> Jacket i a-recompress Start i a = Leaf i a -- Unrolled: The lens case.-recompress (ApL m _ _ li Start r) i a = Ap m False False li (Leaf i a) r -- Unrolled: The list case. In particular, a right-biased tree that we haven't moved rightward in.-recompress p i a = go p (Leaf i a) where- go Start q = q- go (ApL m _ _ li q r) l = go q (Ap m False False li l r)- go (ApR m _ _ li l q) r = go q (Ap m False False li l r)-{-# INLINE recompress #-}---- | Walk down the tree to the leftmost child.-startl :: Path i a -> Jacket i a -> r -> (Path i a -> i -> a -> r) -> r-startl p0 (Leaf i a) _ kp = kp p0 i a -- Unrolled: The lens case.-startl p0 (Ap m nl nr li (Leaf i a) r) _ kp = kp (ApL m nl nr li p0 r) i a -- Unrolled: The list case. (Is this one a good idea?)-startl p0 c0 kn kp = go p0 c0 where- go p (Ap m nl nr li l r)- | nullLeft l = go (ApR m nl nr li Pure p) r- | otherwise = go (ApL m nl nr li p r) l- go p (Leaf i a) = kp p i a- go _ Pure = kn-{-# INLINE startl #-}---- | Walk down the tree to the rightmost child.-startr :: Path i a -> Jacket i a -> r -> (Path i a -> i -> a -> r) -> r-startr p0 (Leaf i a) _ kp = kp p0 i a -- Unrolled: The lens case.-startr p0 c0 kn kp = go p0 c0 where- go p (Ap m nl nr li l r)- | nullRight r = go (ApL m nl nr li p Pure) l- | otherwise = go (ApR m nl nr li l p) r- go p (Leaf i a) = kp p i a- go _ Pure = kn-{-# INLINE startr #-}---- | Move left one 'Leaf'.-movel :: Path i a -> Jacket i a -> r -> (Path i a -> i -> a -> r) -> r-movel p0 c0 kn kp = go p0 c0 where- go Start _ = kn- go (ApR m _ _ li l q) r- | nullRight l = go q (Ap m False False li l Pure)- | otherwise = startr (ApL m False False li q r) l kn kp- go (ApL m _ _ li p r) l = go p (Ap m False False li l r)-{-# INLINE movel #-}---- | Move right one 'Leaf'.-mover :: Path i a -> Jacket i a -> r -> (Path i a -> i -> a -> r) -> r-mover p0 c0 kn kp = go p0 c0 where- go Start _ = kn- go (ApL m _ _ li q r) l- | nullLeft r = go q (Ap m False False li Pure r)- | otherwise = startl (ApR m False False li l q) r kn kp- go (ApR m _ _ li l p) r = go p (Ap m False False li l r)-{-# INLINE mover #-}---------------------------------------------------------------------------------- * Zippers---------------------------------------------------------------------------------- | This is used to represent the 'Top' of the 'Zipper'.------ Every 'Zipper' starts with 'Top'.------ /e.g./ @'Top' ':>>' a@ is the type of the trivial 'Zipper'.-data Top---- | 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.------ This type operator associates to the left, so you can use a type like------ @'Top' ':>>' ('String','Double') ':>>' 'String' ':>>' 'Char'@------ to represent a 'Zipper' from @('String','Double')@ down to 'Char' that has an intermediate--- crumb for the 'String' containing the 'Char'.------ You can construct a 'Zipper' into *any* data structure with 'zipper'.------ 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 Zipper h i a = Ord i => Zipper !(Coil h i a) Int !Int !(Path i a) i a---- Top :>> Map String Int :> Int :@ String :>> Bool--infixr 9 :@--- | An empty data type, used to represent the pairing of a position in--- a 'Zipper' with an index. See ':>'.-data (:@) a i--infixl 8 :>--- | This type family represents a 'Zipper' with the @p@ variable--- abstracting over the position and the index, in terms of ':@'. You--- can visually see it in type signatures as:------ @--- h ':>' (a ':@' i) = 'Zipper' h i a--- @----type family (:>) h p-type instance h :> (a :@ i) = Zipper h i a--infixl 8 :>>--- | Many zippers are indexed by Int keys. This type alias is convenient for reducing syntactic noise for talking about these boring indices.-type h :>> a = Zipper h Int a---- | 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 (Zipper h i a) s = Zipped h a---- | 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.-#ifndef HLINT-data Coil t i a where- Coil :: Coil Top Int a- Snoc :: Ord i => !(Coil h j s) -> AnIndexedTraversal' i s a -> Int -> !Int -> !(Path j s) -> j -> (Jacket i a -> s) -> Coil (Zipper h j s) i a-#endif---- | This 'Lens' views the current target of the 'Zipper'.-focus :: IndexedLens' i (Zipper h i a) a-focus f (Zipper h t o p i a) = Zipper h t o p i <$> indexed f i a-{-# INLINE focus #-}---- | Construct a 'Zipper' that can explore anything, and start it at the 'Top'.-zipper :: a -> Top :>> a-zipper = Zipper Coil 0 0 Start 0-{-# INLINE zipper #-}---- | Return the index of the focus.-focalPoint :: Zipper h i a -> i-focalPoint (Zipper _ _ _ _ i _) = i-{-# INLINE focalPoint #-}---- | Return the index into the current 'Traversal' within the current level of the 'Zipper'.------ @'jerkTo' ('tooth' l) l = 'Just'@------ Mnemonically, zippers have a number of 'teeth' within each level. This is which 'tooth' you are currently at.------ This is based on ordinal position regardless of the underlying index type. It may be excessively expensive for a list.------ 'focalPoint' may be much cheaper if you have a 'Traversal' indexed by ordinal position!-tooth :: Zipper h i a -> Int-tooth (Zipper _ t o _ _ _) = t + o-{-# INLINE tooth #-}---- | 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.----upward :: Ord j => h :> s:@j :> a:@i -> h :> s:@j-upward (Zipper (Snoc h _ t o p j k) _ _ q i x) = Zipper h t o p j $ k $ recompress q i x-{-# INLINE upward #-}---- | 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:@i -> m (h :> a:@i)-rightward (Zipper h t o p i a) = mover p (Leaf i a) mzero $ \q j b -> return $ Zipper h t (o + 1) q j b where-{-# INLINE rightward #-}---- | 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---- >>> 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:@i -> m (h :> a:@i)-leftward (Zipper h t o p i a) = movel p (Leaf i a) mzero $ \q j b -> return $ Zipper h t (o - 1) q j b-{-# INLINE leftward #-}---- | Move to the leftmost position of the current 'Traversal'.------ This is just a convenient alias for @'farthest' 'leftward'@.------ >>> zipper "hello" & fromWithin traverse & leftmost & focus .~ 'a' & rezip--- "aello"-leftmost :: a :> b:@i -> a :> b:@i-leftmost (Zipper h _ _ p i a) = startl Start (recompress p i a) (error "leftmost: bad Jacket structure") (Zipper h 0 0)-{-# INLINE leftmost #-}---- | 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:@i -> a :> b:@i-rightmost (Zipper h _ _ p i a) = startr Start (recompress p i a) (error "rightmost: bad Jacket structure") (\q -> Zipper h (offset q) 0 q)-{-# INLINE rightmost #-}---- | 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' '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"- | otherwise = go n0- where- go 0 a = a- go n a = maybe a (go (n - 1)) (f a)-{-# INLINE tugs #-}---- | 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 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 = fail "jerks: negative jerk count"- | otherwise = go n0- where- go 0 a = return a- go n a = f a >>= go (n - 1)-{-# INLINE jerks #-}---- | Returns the number of siblings at the current level in the 'Zipper'.------ @'teeth' z '>=' 1@------ /NB:/ If the current 'Traversal' targets an infinite number of elements then this may not terminate.------ This is also a particularly expensive operation to perform on an unbalanced tree.------ >>> 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:@i -> Int-teeth (Zipper _ _ _ p _ _) = pathsize p-{-# INLINE teeth #-}---- | 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' '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:@i) -> m (h :> a:@i)-jerkTo n z = case compare k n of- 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' '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' 'rightward' n '.' 'farthest' 'leftward'@------ >>> rezip $ zipper "not working." & fromWithin traverse & tugTo 100 & focus .~ '!' & tugTo 1 & focus .~ 'u'--- "nut working!"-tugTo :: Int -> h :> a:@i -> h :> a:@i-tugTo n z = case compare k n of- LT -> tugs rightward (n - k) z- EQ -> z- GT -> tugs leftward (k - n) z- where k = tooth z-{-# INLINE tugTo #-}---- | Move towards a particular index in the current 'Traversal'.-moveToward :: i -> h :> a:@i -> h :> a:@i-moveToward i z@(Zipper h _ _ p0 j s0)- | i == j = z- | otherwise = go Start (recompress p0 j s0)- where- go _ Pure = z- go p (Ap m nl nr li l r)- | Last (Just k) <- maximal l, k >= i = go (ApL m nl nr li p r) l- | otherwise = go (ApR m nl nr li l p) r- go p (Leaf k a) = Zipper h (offset p) 0 p k a-{-# INLINE moveToward #-}---- | Move horizontally to a particular index @i@ in the current--- 'Traversal'. In the case of simple zippers, the index is 'Int' and--- we can move between traversals fairly easily:------ >>> zipper (42, 32) & fromWithin both & moveTo 0 <&> view focus--- 42------ >>> zipper (42, 32) & fromWithin both & moveTo 1 <&> view focus--- 32----moveTo :: MonadPlus m => i -> h :> a:@i -> m (h :> a:@i)-moveTo i z = case moveToward i z of- z'@(Zipper _ _ _ _ j _)- | i == j -> return z'- | otherwise -> mzero-{-# INLINE moveTo #-}---- | Construct an 'IndexedLens' from 'ALens' where the index is fixed to @0@.-lensed :: ALens' s a -> IndexedLens' Int s a-lensed l f = cloneLens l (indexed f (0 :: Int))-{-# INLINE lensed #-}---- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know--- there is precisely one target that can never fail.------ @--- 'downward' :: 'Lens'' s a -> (h ':>' s) -> h ':>' s ':>' a--- 'downward' :: 'Iso'' s a -> (h ':>' s) -> h ':>' s ':>' a--- @-downward :: forall j h s a. ALens' s a -> h :> s:@j -> h :> s:@j :>> a-downward l (Zipper h t o p j s) = Zipper (Snoc h l' t o p j go) 0 0 Start 0 (s^.l')- where l' :: IndexedLens' Int s a- l' = lensed l- go (Leaf _ b) = set l' b s- go _ = error "downward: rezipping"-{-# INLINE downward #-}---- | Step down into a 'IndexedLens'. This is a constrained form of 'ifromWithin' for when you know--- there is precisely one target that can never fail.------ @--- 'idownward' :: 'IndexedLens'' i s a -> (h ':>' s:\@j) -> h ':>' s:\@j ':>' a:\@i--- @-idownward :: forall i j h s a. Ord i => AnIndexedLens' i s a -> h :> s:@j -> h :> s:@j :> a:@i-idownward l (Zipper h t o p j s) = Zipper (Snoc h l' t o p j go) 0 0 Start i a- where l' :: IndexedLens' i s a- l' = cloneIndexedLens l- (i, a) = iview l' s- go (Leaf _ b) = set l' b s- go _ = error "idownward: rezipping"-{-# INLINE idownward #-}---- | Step down into the 'leftmost' entry of a 'Traversal'.------ @--- 'within' :: 'Traversal'' s a -> (h ':>' s:\@j) -> 'Maybe' (h ':>' s:\@j ':>>' a)--- 'within' :: 'Prism'' s a -> (h ':>' s:\@j) -> 'Maybe' (h ':>' s:\@j ':>>' a)--- 'within' :: 'Lens'' s a -> (h ':>' s:\@j) -> 'Maybe' (h ':>' s:\@j ':>>' a)--- 'within' :: 'Iso'' s a -> (h ':>' s:\@j) -> 'Maybe' (h ':>' s:\@j ':>>' a)--- @------ @--- 'within' :: 'MonadPlus' m => 'ATraversal'' s a -> (h ':>' s:\@j) -> m (h ':>' s:\@j ':>>' a)--- @-within :: MonadPlus m => LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> m (h :> s:@j :>> a)-within = iwithin . indexing-{-# INLINE within #-}---- | Step down into the 'leftmost' entry of an 'IndexedTraversal'.------ /Note:/ The index is assumed to be ordered and must increase monotonically or else you cannot (safely) 'moveTo' or 'moveToward' or use tapes.------ @--- 'iwithin' :: 'IndexedTraversal'' i s a -> (h ':>' s:\@j) -> 'Maybe' (h ':>' s:\@j ':>' a:\@i)--- 'iwithin' :: 'IndexedLens'' i s a -> (h ':>' s:\@j) -> 'Maybe' (h ':>' s:\@j ':>' a:\@i)--- @------ @--- 'iwithin' :: 'MonadPlus' m => 'ATraversal'' s a -> (h ':>' s:\@j) -> m (h ':>' s:\@j ':>>' a)--- @-iwithin :: (MonadPlus m, Ord i) => AnIndexedTraversal' i s a -> (h :> s:@j) -> m (h :> s:@j :> a:@i)-iwithin l (Zipper h t o p j s) = case jacket l (Context id) s of- Context k xs -> startl Start xs mzero $ \q i a -> return $ Zipper (Snoc h l t o p j k) 0 0 q i a-{-# INLINE iwithin #-}---- | Step down into every entry of a 'Traversal' simultaneously.------ >>> zipper ("hello","world") & withins both >>= leftward >>= withins traverse >>= rightward <&> focus %~ toUpper <&> rezip :: [(String,String)]--- [("hEllo","world"),("heLlo","world"),("helLo","world"),("hellO","world")]------ @--- 'withins' :: 'Traversal'' s a -> (h ':>' s:\@j) -> [h ':>' s:\@j ':>>' a]--- 'withins' :: 'Lens'' s a -> (h ':>' s:\@j) -> [h ':>' s:\@j ':>>' a]--- 'withins' :: 'Iso'' s a -> (h ':>' s:\@j) -> [h ':>' s:\@j ':>>' a]--- @-withins :: MonadPlus m => LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> m (h :> s:@j :>> a)-withins = iwithins . indexing-{-# INLINE withins #-}---- | Step down into every entry of an 'IndexedTraversal' simultaneously.------ /Note:/ The index is assumed to be ordered and must increase monotonically or else you cannot (safely) 'moveTo' or 'moveToward' or use tapes.------ @--- 'iwithins' :: 'IndexedTraversal'' i s a -> (h ':>' s:\@j) -> [h ':>' s:\@j ':>' a:\@i]--- 'iwithins' :: 'IndexedLens'' i s a -> (h ':>' s:\@j) -> [h ':>' s:\@j ':>' a:\@i]--- @-iwithins :: (MonadPlus m, Ord i) => AnIndexedTraversal' i s a -> (h :> s:@j) -> m (h :> s:@j :> a:@i)-iwithins z (Zipper h t o p j s) = case jacket z (Context id) s of- Context k xs -> let up = Snoc h z t o p j k- go q (Ap m nl nr li l r) = go (ApL m nl nr li q r) l `mplus` go (ApR m nl nr li l q) r- go q (Leaf i a) = return $ Zipper up (offset q) 0 q i a- go _ Pure = mzero- in go Start xs-{-# INLINE iwithins #-}---- | 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' :: 'Traversal'' s a -> (h ':>' s:\@j) -> h ':>' s:\@j ':>>' a--- 'fromWithin' :: 'Lens'' s a -> (h ':>' s:\@j) -> h ':>' s:\@j ':>>' a--- 'fromWithin' :: 'Iso'' s a -> (h ':>' s:\@j) -> h ':>' s:\@j ':>>' a--- @------ You can reason about this function as if the definition was:------ @--- 'fromWithin' l ≡ 'fromJust' '.' 'within' l--- @-fromWithin :: LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> h :> s:@j :>> a-fromWithin = ifromWithin . indexing-{-# INLINE fromWithin #-}---- | Unsafey step down into an 'IndexedTraversal' that is /assumed/ to be non-empty------ If this invariant is not met then this will usually result in an error!------ @--- 'ifromWithin' :: 'IndexedTraversal'' i s a -> (h ':>' s:\@j) -> h ':>' s:\@j ':>' a:\@i--- 'ifromWithin' :: 'IndexedLens'' i s a -> (h ':>' s:\@j) -> h ':>' s:\@j ':>' a:\@i--- @------ You can reason about this function as if the definition was:------ @--- 'fromWithin' l ≡ 'fromJust' '.' 'within' l--- @-ifromWithin :: Ord i => AnIndexedTraversal' i s a -> (h :> s:@j) -> h :> s:@j :> a:@i-ifromWithin l (Zipper h t o p j s) = case jacket l (Context id) s of- Context k xs -> let up = Snoc h l t o p j k in- startl Start xs (Zipper up 0 0 Start (error "fromWithin an empty Traversal")- (error "fromWithin an empty Traversal"))- (Zipper up 0 0)-{-# INLINE ifromWithin #-}---- | This enables us to pull the 'Zipper' back up to the 'Top'.-class Zipping h a where- recoil :: Coil h i a -> Jacket i a -> Zipped h a--instance Zipping Top a where- recoil Coil (Leaf _ a) = a- recoil Coil _ = error "recoil: expected Leaf"- {-# INLINE recoil #-}--instance Zipping h s => Zipping (Zipper h i s) a where- recoil (Snoc h _ _ _ p i k) as = recoil h $ recompress p i (k as)- {-# INLINE recoil #-}---- | Close something back up that you opened as a 'Zipper'.-rezip :: Zipping h a => (h :> a:@i) -> Zipped h a-rezip (Zipper h _ _ p i a) = recoil h (recompress p i a)-{-# INLINE rezip #-}---- | Extract the current 'focus' from a 'Zipper' as a 'Pretext', with access to the current index.-focusedContext :: (Indexable i p, Zipping h a) => (h :> a:@i) -> Pretext p a a (Zipped h a)-focusedContext (Zipper h t o p i a) = Pretext (\f -> rezip . Zipper h t o p i <$> indexed f i a)-{-# INLINE focusedContext #-}---------------------------------------------------------------------------------- * Tapes---------------------------------------------------------------------------------- | A 'Tape' is a recorded path through the (indexed) 'Traversal' chain of a 'Zipper'.-data Tape h i a where- Tape :: Track h i a -> i -> Tape h i a---- | Save the current path as as a 'Tape' we can play back later.-saveTape :: Zipper h i a -> Tape h i a-saveTape (Zipper h _ _ _ i _) = Tape (peel h) i-{-# INLINE saveTape #-}---- | Restore ourselves to a previously recorded position precisely.------ If the position does not exist, then fail.-restoreTape :: MonadPlus m => Tape h i a -> Zipped h a -> m (Zipper h i a)-restoreTape (Tape h n) = restoreTrack h >=> moveTo 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 :: MonadPlus m => Tape h i a -> Zipped h a -> m (Zipper h i a)-restoreNearTape (Tape h n) a = liftM (moveToward 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 '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 i a -> Zipped h a -> Zipper h i a-unsafelyRestoreTape (Tape h n) = unsafelyRestoreTrack h >>> moveToward n-{-# INLINE unsafelyRestoreTape #-}---------------------------------------------------------------------------------- * Tracks---------------------------------------------------------------------------------- | 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 i a -> Track h i a-peel Coil = Track-peel (Snoc h l _ _ _ i _) = Fork (peel h) i l-{-# INLINE peel #-}---- | The 'Track' forms the bulk of a 'Tape'.-data Track t i a where- Track :: Track Top Int a- Fork :: Ord i => Track h j s -> j -> AnIndexedTraversal' i s a -> Track (Zipper h j s) i a---- | Restore ourselves to a previously recorded position precisely.------ If the position does not exist, then fail.-restoreTrack :: MonadPlus m => Track h i a -> Zipped h a -> m (Zipper h i a)-restoreTrack Track = return . zipper-restoreTrack (Fork h n l) = restoreTrack h >=> moveTo n >=> iwithin l---- | Restore ourselves to a location near our previously recorded position.------ 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 :: MonadPlus m => Track h i a -> Zipped h a -> m (Zipper h i a)-restoreNearTrack Track = return . zipper-restoreNearTrack (Fork h n l) = restoreNearTrack h >=> moveToward n >>> iwithin 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 '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 i a -> Zipped h a -> Zipper h i a-unsafelyRestoreTrack Track = zipper-unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> moveToward n >>> ifromWithin l-
src/Control/Lens/Internal/Zoom.hs view
@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Zoom--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -36,7 +36,6 @@ import Control.Category import Control.Comonad import Control.Lens.Internal.Action-import Control.Lens.Internal.Getter import Control.Monad.Reader as Reader import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict@@ -262,7 +261,7 @@ -- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. type family Magnified (m :: * -> *) :: * -> * -> * type instance Magnified (ReaderT b m) = Effect m-type instance Magnified ((->)b) = Accessor+type instance Magnified ((->)b) = Const type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m type instance Magnified (IdentityT m) = Magnified m
src/Control/Lens/Iso.hs view
@@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Iso--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -37,13 +37,14 @@ , mapping -- ** Common Isomorphisms , simple- , non+ , non, non' , anon , enum , curried, uncurried , flipped , Swapped(..) , Strict(..)+ , lazy , Reversing(..), reversed , involuted -- ** Uncommon Isomorphisms@@ -59,11 +60,13 @@ , rmapping ) where +import Control.Lens.Fold import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Control.Lens.Internal.Iso as Iso import Control.Lens.Internal.Magma-import Control.Lens.Internal.Setter+import Control.Lens.Prism+import Control.Lens.Review import Control.Lens.Type import Control.Monad.State.Lazy as Lazy import Control.Monad.State.Strict as Strict@@ -71,10 +74,10 @@ import Control.Monad.Writer.Strict as Strict import Control.Monad.RWS.Lazy as Lazy import Control.Monad.RWS.Strict as Strict-import Data.Bifunctor import Data.ByteString as StrictB hiding (reverse) import Data.ByteString.Lazy as LazyB hiding (reverse) import Data.Functor.Contravariant+import Data.Functor.Identity import Data.Text as StrictT hiding (reverse) import Data.Text.Lazy as LazyT hiding (reverse) import Data.Tuple (swap)@@ -98,7 +101,7 @@ ----------------------------------------------------------------------------- -- | When you see this as an argument to a function, it expects an 'Iso'.-type AnIso s t a b = Exchange a b a (Mutator b) -> Exchange a b s (Mutator t)+type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t) -- | A 'Simple' 'AnIso'. type AnIso' s a = AnIso s s a a@@ -109,8 +112,8 @@ -- @ -- 'Control.Lens.Getter.view' ('iso' f g) ≡ f -- 'Control.Lens.Getter.view' ('Control.Lens.Iso.from' ('iso' f g)) ≡ g--- 'Control.Lens.Setter.set' ('iso' f g) h ≡ g '.' h '.' f--- 'Control.Lens.Setter.set' ('Control.Lens.Iso.from' ('iso' f g)) h ≡ f '.' h '.' g+-- 'Control.Lens.Setter.over' ('iso' f g) h ≡ g '.' h '.' f+-- 'Control.Lens.Setter.over' ('Control.Lens.Iso.from' ('iso' f g)) h ≡ f '.' h '.' g -- @ iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt)@@ -132,8 +135,8 @@ -- | Extract the two functions, one from @s -> a@ and -- one from @b -> t@ that characterize an 'Iso'. withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r-withIso ai k = case ai (Exchange id Mutator) of- Exchange sa bt -> k sa (runMutator #. bt)+withIso ai k = case ai (Exchange id Identity) of+ Exchange sa bt -> k sa (runIdentity #. bt) {-# INLINE withIso #-} -- | Convert from 'AnIso' back to any 'Iso'.@@ -143,7 +146,7 @@ -- -- See 'Control.Lens.Lens.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 k = withIso k $ \ sa bt -> iso sa bt+cloneIso k = withIso k iso {-# INLINE cloneIso #-} -----------------------------------------------------------------------------@@ -154,7 +157,7 @@ -- -- This version is generalized to accept any 'Iso', not just a @newtype@. ----- >>> au (wrapping Sum) foldMap [1,2,3,4]+-- >>> au (_Unwrapping Sum) foldMap [1,2,3,4] -- 10 au :: AnIso s t a b -> ((s -> a) -> e -> b) -> e -> t au k = withIso k $ \ sa bt f e -> bt (f sa e)@@ -169,10 +172,10 @@ -- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator -- is 'au' with an extra function argument. ----- >>> auf (wrapping Sum) (foldMapOf both) Prelude.length ("hello","world")+-- >>> auf (_Unwrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10-auf :: AnIso s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t-auf k = withIso k $ \ sa bt f g e -> bt (f (sa . g) e)+auf :: Profunctor p => AnIso s t a b -> (p r a -> e -> b) -> p r s -> e -> t+auf k = withIso k $ \ sa bt f g e -> bt (f (rmap sa g) e) {-# INLINE auf #-} -- | The opposite of working 'Control.Lens.Setter.over' a 'Setter' is working 'under' an isomorphism.@@ -225,6 +228,10 @@ -- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@, then @'non' v@ is an isomorphism from -- @'Maybe' a'@ to @a@. --+-- @+-- 'non' ≡ 'anon' '.' 'only'+-- @+-- -- Keep in mind this is only a real isomorphism if you treat the domain as being @'Maybe' (a sans v)@. -- -- This is practically quite useful when you want to have a 'Data.Map.Map' where all the entries should have non-zero values.@@ -254,9 +261,25 @@ -- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing -- fromList [] non :: Eq a => a -> Iso' (Maybe a) a-non a = anon a (a==)+non = non' . only {-# INLINE non #-} +-- | @'non_' p@ generalizes @'non' (p # ())@ to take any unit 'Prism'+--+-- This function generates an isomorphism between @'Maybe' (a | 'isn't' p a)@ and @a@.+--+-- >>> Map.singleton "hello" Map.empty & at "hello" . non' _Empty . at "world" ?~ "!!!"+-- fromList [("hello",fromList [("world","!!!")])]+--+-- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing+-- fromList []+non' :: APrism' a () -> Iso' (Maybe a) a+non' p = iso (fromMaybe def) go where+ def = review (clonePrism p) ()+ go b | has (clonePrism p) b = Nothing+ | otherwise = Just b+{-# 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@.@@ -333,8 +356,8 @@ -- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure, -- such as 'StrictT.Text' or 'StrictB.ByteString'.-class Strict s a | s -> a, a -> s where- strict :: Iso' s a+class Strict lazy strict | lazy -> strict, strict -> lazy where+ strict :: Iso' lazy strict instance Strict LazyB.ByteString StrictB.ByteString where #if MIN_VERSION_bytestring(0,10,0)@@ -360,6 +383,17 @@ strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST) {-# INLINE strict #-} +-- | An 'Iso' between the strict variant of a structure and its lazy+-- counterpart.+--+-- @+-- 'lazy' = 'from' 'strict'+-- @+--+-- See <http://hackage.haskell.org/package/strict-base-types> for an example+-- use.+lazy :: Strict lazy strict => Iso' strict lazy+lazy = from strict -- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal. --@@ -400,7 +434,7 @@ -- | This isomorphism can be used to inspect an 'IndexedTraversal' to see how it associates -- the structure and it can also be used to bake the 'IndexedTraversal' into a 'Magma' so -- that you can traverse over it multiple times with access to the original indices.-imagma :: Overloading (Indexed i) (->) (Molten i a b) s t a b -> Iso s t' (Magma i t b a) (Magma j t' c c)+imagma :: Over (Indexed i) (Molten i a b) s t a b -> Iso s t' (Magma i t b a) (Magma j t' c c) imagma l = iso (runMolten #. l sell) (iextract .# Molten) {-# INLINE imagma #-}
src/Control/Lens/Lens.hs view
@@ -15,7 +15,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -72,6 +72,8 @@ , (%%@~), (%%@=) , (<%@~), (<%@=) , (<<%@~), (<<%@=)+ -- ** General Purpose Combinators+ , (&), (<&>), (??) -- * Lateral Composition , choosing@@ -83,13 +85,17 @@ , (<%~), (<+~), (<-~), (<*~), (<//~) , (<^~), (<^^~), (<**~) , (<||~), (<&&~), (<<>~)- , (<<%~), (<<.~)+ , (<<%~), (<<.~), (<<+~), (<<-~), (<<*~)+ , (<<//~), (<<^~), (<<^^~), (<<**~)+ , (<<||~), (<<&&~), (<<<>~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (<//=) , (<^=), (<^^=), (<**=) , (<||=), (<&&=), (<<>=)- , (<<%=), (<<.=)+ , (<<%=), (<<.=), (<<+=), (<<-=), (<<*=)+ , (<<//=), (<<^=), (<<^^=), (<<**=)+ , (<<||=), (<<&&=), (<<<>=) , (<<~) -- * Cloning Lenses@@ -97,6 +103,9 @@ , cloneIndexPreservingLens , cloneIndexedLens + -- * Arrow operators+ , overA+ -- * ALens Combinators , storing , (^#)@@ -114,9 +123,10 @@ ) where import Control.Applicative+import Control.Arrow import Control.Comonad-import Control.Lens.Combinators import Control.Lens.Internal.Context+import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.State as State@@ -133,6 +143,7 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Control.Monad.State -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -145,6 +156,7 @@ infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~, <#~, #~, #%~, <#%~, #%%~ infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.=, <#=, #=, #%=, <#%=, #%%= infixr 2 <<~+infixl 1 &, <&>, ?? ------------------------------------------------------------------------------- -- Lenses@@ -163,7 +175,7 @@ type ALens' s a = ALens s s a a -- | When you see this as an argument to a function, it expects an 'IndexedLens'-type AnIndexedLens i s t a b = Overloading (Indexed i) (->) (Pretext (Indexed i) a b) s t a b+type AnIndexedLens i s t a b = Optical (Indexed i) (->) (Pretext (Indexed i) a b) s t a b -- | @ -- type 'AnIndexedLens'' = 'Simple' ('AnIndexedLens' i)@@ -189,17 +201,16 @@ -- >>> s & lens getter setter %~ f -- setter s (f (getter s)) --+-- @+-- 'lens' :: (s -> a) -> (s -> a -> s) -> 'Lens'' s a+-- @ lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} --- | Build an index-preserving 'Lens' from a 'Control.Lens.Getter.Getter' and a 'Control.Lens.Setter.Setter'.------ @--- 'lens' :: (s -> a) -> (s -> b -> t) -> 'Lens' s t a b--- 'lens' sa sbt afb s = sbt s '<$>' afb (sa s)--- @-iplens :: (Conjoined p, Functor f) => (s -> a) -> (s -> b -> t) -> Overloaded p f s t a b+-- | Build an index-preserving 'Lens' from a 'Control.Lens.Getter.Getter' and a+-- 'Control.Lens.Setter.Setter'.+iplens :: (s -> a) -> (s -> b -> t) -> IndexPreservingLens s t a b iplens sa sbt pafb = cotabulate $ \ws -> sbt (extract ws) <$> corep pafb (sa <$> ws) {-# INLINE iplens #-} @@ -242,7 +253,7 @@ -- ('%%~') :: 'Lens' s t a b -> (a -> (r, b)) -> s -> (r, t) -- ('%%~') :: 'Monoid' m => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> (m, b)) -> s -> (m, t) -- @-(%%~) :: Overloading p q f s t a b -> p a (f b) -> q s (f t)+(%%~) :: Optical p q f s t a b -> p a (f b) -> q s (f t) (%%~) = id {-# INLINE (%%~) #-} @@ -266,7 +277,7 @@ -- ('%%=') :: 'MonadState' s m => 'Lens' s s a b -> (a -> (r, b)) -> m r -- ('%%=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Traversal.Traversal' s s a b -> (a -> (r, b)) -> m r -- @-(%%=) :: MonadState s m => Overloading p (->) ((,) r) s s a b -> p a (r, b) -> m r+(%%=) :: MonadState s m => Over p ((,) r) s s a b -> p a (r, b) -> m r #if MIN_VERSION_mtl(2,1,1) l %%= f = State.state (l f) #else@@ -278,19 +289,79 @@ {-# INLINE (%%=) #-} -------------------------------------------------------------------------------+-- General Purpose Combinators+-------------------------------------------------------------------------------++-- | Passes the result of the left side to the function on the right side (forward pipe operator).+--+-- This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed+-- 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 (&) #-}++-- | Infix flipped 'fmap'.+--+-- @+-- ('<&>') = 'flip' 'fmap'+-- @+(<&>) :: Functor f => f a -> (a -> b) -> f b+as <&> f = f <$> as+{-# INLINE (<&>) #-}++-- | This is convenient to 'flip' argument order of composite functions.+--+-- >>> over _2 ?? ("hello","world") $ length+-- ("hello",5)+--+-- >>> over ?? length ?? ("hello","world") $ _2+-- ("hello",5)+(??) :: Functor f => f (a -> b) -> a -> f b+fab ?? a = fmap ($ a) fab+{-# INLINE (??) #-}++------------------------------------------------------------------------------- -- Common Lenses ------------------------------------------------------------------------------- --- | Lift a 'Lens' so it can run under a function.+-- | Lift a 'Lens' so it can run under a function (or other corepresentable profunctor). ---inside :: ALens s t a b -> Lens (e -> s) (e -> t) (e -> a) (e -> b)+-- @+-- 'inside' :: 'Lens' s t a b -> 'Lens' (e -> s) (e -> t) (e -> a) (e -> b)+-- @+--+inside :: Corepresentable p => ALens s t a b -> Lens (p e s) (p e t) (p e a) (p e b) inside l f es = o <$> f i where- i e = ipos (l sell (es e))- o ea e = ipeek (ea e) (l sell (es e))--- 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)+ i = cotabulate $ \ e -> ipos $ l sell (corep es e)+ o ea = cotabulate $ \ e -> ipeek (corep ea e) $ l sell (corep es e) {-# INLINE inside #-} +{-+-- | Lift a 'Lens' so it can run under a function (or any other corepresentable functor).+insideF :: F.Representable f => ALens s t a b -> Lens (f s) (f t) (f a) (f b)+insideF l f es = o <$> f i where+ i = F.tabulate $ \e -> ipos $ l sell (F.index es e)+ o ea = F.tabulate $ \ e -> ipeek (F.index ea e) $ l sell (F.index es e)+{-# INLINE inside #-}+-}+ -- | Merge two lenses, getters, setters, folds or traversals. -- -- @@@ -341,7 +412,8 @@ Right _ -> Right b {-# INLINE chosen #-} --- | 'alongside' makes a 'Lens' from two other lenses.+-- | 'alongside' makes a 'Lens' from two other lenses or a 'Getter' from two other getters+-- by executing them on their respective halves of a product. -- -- >>> (Left a, Right b)^.alongside chosen chosen -- (a,b)@@ -350,12 +422,16 @@ -- (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' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b')+-- 'alongside' :: 'Getter' s t a b -> 'Getter' s' t' a' b' -> 'Getter' (s,s') (t,t') (a,a') (b,b') -- @-alongside :: ALens s t a b -> ALens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')-alongside l r f (s, s') = f (ipos ls, ipos rs) <&> \(b, b') -> (ipeek b ls, ipeek b' rs) where- ls = l sell s- rs = r sell s'+alongside :: LensLike (AlongsideLeft f b') s t a b+ -> LensLike (AlongsideRight f t) s' t' a' b'+ -> LensLike f (s, s') (t, t') (a, a') (b, b')+alongside l1 l2 f (a1, a2)+ = getAlongsideRight $ l2 ?? a2 $ \b2 -> AlongsideRight+ $ getAlongsideLeft $ l1 ?? a1 $ \b1 -> AlongsideLeft+ $ f (b1,b2) {-# INLINE alongside #-} -- | This 'Lens' lets you 'view' the current 'pos' of any indexed@@ -417,7 +493,7 @@ -- ('<%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> (b, t) -- ('<%~') :: 'Monoid' b => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> (b, t) -- @-(<%~) :: Profunctor p => Overloading p q ((,) b) s t a b -> p a b -> q s (b, t)+(<%~) :: Profunctor p => Optical p q ((,) b) s t a b -> p a b -> q s (b, t) l <%~ f = l $ rmap (\t -> (t, t)) f {-# INLINE (<%~) #-} @@ -429,7 +505,7 @@ -- ('<+~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<+~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @-(<+~) :: Num a => Overloading (->) q ((,)a) s t a a -> a -> q s (a, t)+(<+~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) l <+~ a = l <%~ (+ a) {-# INLINE (<+~) #-} @@ -441,7 +517,7 @@ -- ('<-~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<-~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @-(<-~) :: Num a => Overloading (->) q ((,)a) s t a a -> a -> q s (a, t)+(<-~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) l <-~ a = l <%~ subtract a {-# INLINE (<-~) #-} @@ -454,7 +530,7 @@ -- ('<*~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<*~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @-(<*~) :: Num a => Overloading (->) q ((,)a) s t a a -> a -> q s (a, t)+(<*~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) l <*~ a = l <%~ (* a) {-# INLINE (<*~) #-} @@ -466,46 +542,46 @@ -- ('<//~') :: 'Fractional' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<//~') :: 'Fractional' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @-(<//~) :: Fractional a => Overloading (->) q ((,)a) s t a a -> a -> q s (a, t)+(<//~) :: Fractional a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) l <//~ a = l <%~ (/ a) {-# INLINE (<//~) #-} -- | Raise the target of a numerically valued 'Lens' to a non-negative -- 'Integral' power and return the result. ----- When you do not need the result of the division, ('Control.Lens.Setter.^~') is more flexible.+-- When you do not need the result of the operation, ('Control.Lens.Setter.^~') is more flexible. -- -- @ -- ('<^~') :: ('Num' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) -- ('<^~') :: ('Num' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @-(<^~) :: (Num a, Integral e) => Overloading (->) q ((,)a) s t a a -> e -> q s (a, t)+(<^~) :: (Num a, Integral e) => Optical (->) q ((,)a) s t a a -> e -> q s (a, t) l <^~ e = l <%~ (^ e) {-# INLINE (<^~) #-} -- | Raise the target of a fractionally valued 'Lens' to an 'Integral' power -- and return the result. ----- When you do not need the result of the division, ('Control.Lens.Setter.^^~') is more flexible.+-- When you do not need the result of the operation, ('Control.Lens.Setter.^^~') is more flexible. -- -- @ -- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) -- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @-(<^^~) :: (Fractional a, Integral e) => Overloading (->) q ((,)a) s t a a -> e -> q s (a, t)+(<^^~) :: (Fractional a, Integral e) => Optical (->) q ((,)a) s t a a -> e -> q s (a, t) l <^^~ e = l <%~ (^^ e) {-# INLINE (<^^~) #-} -- | Raise the target of a floating-point valued 'Lens' to an arbitrary power -- and return the result. ----- When you do not need the result of the division, ('Control.Lens.Setter.**~') is more flexible.+-- When you do not need the result of the operation, ('Control.Lens.Setter.**~') is more flexible. -- -- @ -- ('<**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<**~') :: 'Floating' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @-(<**~) :: Floating a => Overloading (->) q ((,)a) s t a a -> a -> q s (a, t)+(<**~) :: Floating a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) l <**~ a = l <%~ (** a) {-# INLINE (<**~) #-} @@ -517,7 +593,7 @@ -- ('<||~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<||~') :: 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @-(<||~) :: Overloading (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t)+(<||~) :: Optical (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t) l <||~ b = l <%~ (|| b) {-# INLINE (<||~) #-} @@ -529,7 +605,7 @@ -- ('<&&~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<&&~') :: 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @-(<&&~) :: Overloading (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t)+(<&&~) :: Optical (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t) l <&&~ b = l <%~ (&& b) {-# INLINE (<&&~) #-} @@ -542,7 +618,7 @@ -- ('<<%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> (a, t) -- ('<<%~') :: 'Monoid' a => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> (a, t) -- @-(<<%~) :: Strong p => Overloading p q ((,)a) s t a b -> p a b -> q s (a, t)+(<<%~) :: Strong p => Optical p q ((,)a) s t a b -> p a b -> q s (a, t) (<<%~) l = l . lmap (\a -> (a, a)) . second' {-# INLINE (<<%~) #-} @@ -555,10 +631,50 @@ -- ('<<.~') :: 'Control.Lens.Iso.Iso' s t a b -> b -> s -> (a, t) -- ('<<.~') :: 'Monoid' a => 'Control.Lens.Traversal.Traversal' s t a b -> b -> s -> (a, t) -- @-(<<.~) :: Overloading (->) q ((,)a) s t a b -> b -> q s (a, t)+(<<.~) :: Optical (->) q ((,)a) s t a b -> b -> q s (a, t) l <<.~ b = l $ \a -> (a, b) {-# INLINE (<<.~) #-} +(<<+~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s)+l <<+~ b = l $ \a -> (a, a + b)+{-# INLINE (<<+~) #-}++(<<-~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s)+l <<-~ b = l $ \a -> (a, a - b)+{-# INLINE (<<-~) #-}++(<<*~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s)+l <<*~ b = l $ \a -> (a, a * b)+{-# INLINE (<<*~) #-}++(<<//~) :: Fractional a => Optical' (->) q ((,) a) s a -> a -> q s (a, s)+l <<//~ b = l $ \a -> (a, a / b)+{-# INLINE (<<//~) #-}++(<<^~) :: (Num a, Integral e) => Optical' (->) q ((,) a) s a -> e -> q s (a, s)+l <<^~ e = l $ \a -> (a, a ^ e)+{-# INLINE (<<^~) #-}++(<<^^~) :: (Fractional a, Integral e) => Optical' (->) q ((,) a) s a -> e -> q s (a, s)+l <<^^~ e = l $ \a -> (a, a ^^ e)+{-# INLINE (<<^^~) #-}++(<<**~) :: Floating a => Optical' (->) q ((,) a) s a -> a -> q s (a, s)+l <<**~ e = l $ \a -> (a, a ** e)+{-# INLINE (<<**~) #-}++(<<||~) :: Optical' (->) q ((,) Bool) s Bool -> Bool -> q s (Bool, s)+l <<||~ b = l $ \a -> (a, b || a)+{-# INLINE (<<||~) #-}++(<<&&~) :: Optical' (->) q ((,) Bool) s Bool -> Bool -> q s (Bool, s)+l <<&&~ b = l $ \a -> (a, b && a)+{-# INLINE (<<&&~) #-}++(<<<>~) :: Monoid r => Optical' (->) q ((,) r) s r -> r -> q s (r, s)+l <<<>~ b = l $ \a -> (a, a `mappend` b)+{-# INLINE (<<<>~) #-}+ ------------------------------------------------------------------------------- -- Setting and Remembering State -------------------------------------------------------------------------------@@ -576,7 +692,7 @@ -- ('<%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> a) -> m a -- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a -- @-(<%=) :: (Profunctor p, MonadState s m) => Overloading p (->) ((,)b) s s a b -> p a b -> m b+(<%=) :: (Profunctor p, MonadState s m) => Over p ((,)b) s s a b -> p a b -> m b l <%= f = l %%= rmap (\b -> (b, b)) f {-# INLINE (<%=) #-} @@ -639,7 +755,7 @@ -- | Raise the target of a numerically valued 'Lens' into your 'Monad'\'s state -- to a non-negative 'Integral' power and return the result. ----- When you do not need the result of the operation, ('Control.Lens.Setter.**=') is more flexible.+-- When you do not need the result of the operation, ('Control.Lens.Setter.^=') is more flexible. -- -- @ -- ('<^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Lens'' s a -> e -> m a@@ -716,7 +832,7 @@ -- @ -- -- @('<<%=') :: 'MonadState' s m => 'LensLike' ((,)a) s s a b -> (a -> b) -> m a@-(<<%=) :: (Strong p, MonadState s m) => Overloading p (->) ((,)a) s s a b -> p a b -> m a+(<<%=) :: (Strong p, MonadState s m) => Over p ((,)a) s s a b -> p a b -> m a l <<%= f = l %%= lmap (\a -> (a,a)) (second' f) {-# INLINE (<<%=) #-} @@ -726,17 +842,57 @@ -- When applied to a 'Control.Lens.Traversal.Traversal', it this will return a monoidal summary of all of the old values -- present. ----- When you do not need the result of the operation, ('Control.Lens.Setter.%=') is more flexible.+-- When you do not need the result of the operation, ('Control.Lens.Setter..=') is more flexible. -- -- @--- ('<<%=') :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m a--- ('<<%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> a) -> m a--- ('<<%=') :: ('MonadState' s m, 'Monoid' t) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a+-- ('<<.=') :: 'MonadState' s m => 'Lens'' s a -> a -> m a+-- ('<<.=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> a -> m a+-- ('<<.=') :: ('MonadState' s m, 'Monoid' t) => 'Control.Lens.Traversal.Traversal'' s a -> a -> m a -- @ (<<.=) :: MonadState s m => LensLike ((,)a) s s a b -> b -> m a l <<.= b = l %%= \a -> (a,b) {-# INLINE (<<.=) #-} +(<<+=) :: (MonadState s m, Num a) => LensLike' ((,) a) s a -> a -> m a+l <<+= n = l %%= \a -> (a, a + n)+{-# INLINE (<<+=) #-}++(<<-=) :: (MonadState s m, Num a) => LensLike' ((,) a) s a -> a -> m a+l <<-= n = l %%= \a -> (a, a - n)+{-# INLINE (<<-=) #-}++(<<*=) :: (MonadState s m, Num a) => LensLike' ((,) a) s a -> a -> m a+l <<*= n = l %%= \a -> (a, a * n)+{-# INLINE (<<*=) #-}++(<<//=) :: (MonadState s m, Fractional a) => LensLike' ((,) a) s a -> a -> m a+l <<//= n = l %%= \a -> (a, a / n)+{-# INLINE (<<//=) #-}++(<<^=) :: (MonadState s m, Num a, Integral e) => LensLike' ((,) a) s a -> e -> m a+l <<^= n = l %%= \a -> (a, a ^ n)+{-# INLINE (<<^=) #-}++(<<^^=) :: (MonadState s m, Fractional a, Integral e) => LensLike' ((,) a) s a -> e -> m a+l <<^^= n = l %%= \a -> (a, a ^^ n)+{-# INLINE (<<^^=) #-}++(<<**=) :: (MonadState s m, Floating a) => LensLike' ((,) a) s a -> a -> m a+l <<**= n = l %%= \a -> (a, a ** n)+{-# INLINE (<<**=) #-}++(<<||=) :: MonadState s m => LensLike' ((,) Bool) s Bool -> Bool -> m Bool+l <<||= b = l %%= \a -> (a, a || b)+{-# INLINE (<<||=) #-}++(<<&&=) :: MonadState s m => LensLike' ((,) Bool) s Bool -> Bool -> m Bool+l <<&&= b = l %%= \a -> (a, a && b)+{-# INLINE (<<&&=) #-}++(<<<>=) :: (MonadState s m, Monoid r) => LensLike' ((,) r) s r -> r -> m r+l <<<>= b = l %%= \a -> (a, a `mappend` b)+{-# INLINE (<<<>=) #-}+ -- | Run a monadic action, and set the target of 'Lens' to its result. -- -- @@@ -757,7 +913,7 @@ -- return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.<>~') is more flexible.-(<<>~) :: Monoid m => Overloading (->) q ((,)m) s t m m -> m -> q s (m, t)+(<<>~) :: Monoid m => Optical (->) q ((,)m) s t m m -> m -> q s (m, t) l <<>~ m = l <%~ (`mappend` m) {-# INLINE (<<>~) #-} @@ -770,6 +926,24 @@ {-# INLINE (<<>=) #-} ------------------------------------------------------------------------------+-- Arrow operators+------------------------------------------------------------------------------++-- | 'Control.Lens.Setter.over' for Arrows.+--+-- Unlike 'Control.Lens.Setter.over', 'overA' can't accept a simple+-- 'Control.Lens.Setter.Setter', but requires a full lens, or close+-- enough.+--+-- @+-- overA :: Arrow ar => Lens s t a b -> ar a b -> ar s t+-- @+overA :: Arrow ar => LensLike (Context a b) s t a b -> ar a b -> ar s t+overA l p = arr (\s -> let (Context f a) = l sell s in (f, a))+ >>> second p+ >>> arr (uncurry id)++------------------------------------------------------------------------------ -- Indexed ------------------------------------------------------------------------------ @@ -787,7 +961,7 @@ -- ('<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (b, t) -- ('<%@~') :: 'Monoid' b => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (b, t) -- @-(<%@~) :: Overloading (Indexed i) q ((,) b) s t a b -> (i -> a -> b) -> q s (b, t)+(<%@~) :: Optical (Indexed i) q ((,) b) s t a b -> (i -> a -> b) -> q s (b, t) l <%@~ f = l (Indexed $ \i a -> let b = f i a in (b, b)) {-# INLINE (<%@~) #-} @@ -799,7 +973,7 @@ -- ('<<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (a, t) -- ('<<%@~') :: 'Monoid' a => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (a, t) -- @-(<<%@~) :: Overloading (Indexed i) q ((,) a) s t a b -> (i -> a -> b) -> q s (a, t)+(<<%@~) :: Optical (Indexed i) q ((,) a) s t a b -> (i -> a -> b) -> q s (a, t) l <<%@~ f = l $ Indexed $ \i a -> second' (f i) (a,a) {-# INLINE (<<%@~) #-}@@ -966,7 +1140,7 @@ l <#~ b = \s -> (b, storing l b s) {-# INLINE (<#~) #-} --- | A version of ('Control.Lens.Setter.<#=') that works on 'ALens'.+-- | A version of ('Control.Lens.Setter.<.=') that works on 'ALens'. (<#=) :: MonadState s m => ALens s s a b -> b -> m b l <#= b = do l #= b
src/Control/Lens/Level.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Level--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -21,7 +21,6 @@ import Control.Applicative import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context-import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Internal.Level import Control.Lens.Traversal@@ -33,7 +32,7 @@ -- >>> import Data.Char levelIns :: Bazaar (->) a b t -> [Level () a]-levelIns = go 0 . (runAccessor #. bazaar (Accessor #. deepening ())) where+levelIns = go 0 . (getConst #. bazaar (Const #. deepening ())) where go k z = k `seq` runDeepening z k $ \ xs b -> xs : if b then (go $! k + 1) z else [] {-# INLINE levelIns #-}@@ -81,7 +80,7 @@ {-# INLINE levels #-} ilevelIns :: Bazaar (Indexed i) a b t -> [Level i a]-ilevelIns = go 0 . (runAccessor #. bazaar (Indexed $ \ i -> Accessor #. deepening i)) where+ilevelIns = go 0 . (getConst #. bazaar (Indexed $ \ i -> Const #. deepening i)) where go k z = k `seq` runDeepening z k $ \ xs b -> xs : if b then (go $! k + 1) z else [] {-# INLINE ilevelIns #-}
src/Control/Lens/Loupe.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Loupe--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Control/Lens/Operators.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Operators--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -15,100 +14,139 @@ -- > import Control.Lens.Operators ---------------------------------------------------------------------------- module Control.Lens.Operators- (- -- * General Purpose- (&), (<&>), (??)-- -- * Getting- , (^.), (^@.)- -- ** Loupes+ ( -- output from scripts/operators -h+ -- * "Control.Lens.Action"+ (^!)+ , (^!!)+ , (^!?)+ , (^@!)+ , (^@!!)+ , (^@!?)+ -- * "Control.Lens.Cons"+ , (<|)+ , (|>)+ -- * "Control.Lens.Fold"+ , (^..)+ , (^?)+ , (^?!)+ , (^@..)+ , (^@?)+ , (^@?!)+ -- * "Control.Lens.Getter"+ , (^.)+ , (^@.)+ -- * "Control.Lens.Indexed"+ , (<.)+ , (.>)+ , (<.>)+ -- * "Control.Lens.Lens"+ , (%%~)+ , (%%=)+ , (&)+ , (<&>)+ , (??)+ , (<%~)+ , (<+~)+ , (<-~)+ , (<*~)+ , (<//~)+ , (<^~)+ , (<^^~)+ , (<**~)+ , (<||~)+ , (<&&~)+ , (<<%~)+ , (<<.~)+ , (<<+~)+ , (<<-~)+ , (<<*~)+ , (<<//~)+ , (<<^~)+ , (<<^^~)+ , (<<**~)+ , (<<||~)+ , (<<&&~)+ , (<<<>~)+ , (<%=)+ , (<+=)+ , (<-=)+ , (<*=)+ , (<//=)+ , (<^=)+ , (<^^=)+ , (<**=)+ , (<||=)+ , (<&&=)+ , (<<%=)+ , (<<.=)+ , (<<+=)+ , (<<-=)+ , (<<*=)+ , (<<//=)+ , (<<^=)+ , (<<^^=)+ , (<<**=)+ , (<<||=)+ , (<<&&=)+ , (<<<>=)+ , (<<~)+ , (<<>~)+ , (<<>=)+ , (<%@~)+ , (<<%@~)+ , (%%@~)+ , (%%@=)+ , (<%@=)+ , (<<%@=) , (^#)- -- ** with Effects- , (^!), (^@!)- , (^!!), (^@!!)- , (^!?), (^@!?)- -- ** from Folds- , (^..), (^@..)- , (^?), (^@?)- , (^?!), (^@?!)-- -- * Reviewing+ , ( #~ )+ , ( #%~ )+ , ( #%%~ )+ , ( #= )+ , ( #%= )+ , (<#%~)+ , (<#%=)+ , ( #%%= )+ , (<#~)+ , (<#=)+ -- * "Control.Lens.Plated"+ , (...)+ -- * "Control.Lens.Review" , ( # )-- -- * Common Operators- -- ** Setting- , (.~) , (.=)- , (<.~), (<.=)- , (<<.~), (<<.=)- --- *** Loupes- , ( #~ ), ( #= )- , (<#~), (<#=)- -- *** Just- , (?~), (?=)- , (<?~), (<?=)-- -- ** Modifying- , (%~), (%=)- , (<%~), (<%=)- , (<<%~), (<<%=)- -- *** Loupes- , ( #%~ ), ( #%= )- , (<#%~), (<#%=)- -- *** with Indices- , (%@~), (%@=)- , (<%@~), (<%@=)- , (<<%@~), (<<%@=)-- -- ** Traversing- , (%%~), (%%=)- --- *** Loupes- , ( #%%~ ), ( #%%= )- --- *** with Indices- , (%%@~), (%%@=)-- -- ** Addition- , (+~), (+=), (<+~), (<+=)- -- ** Subtraction- , (-~), (-=), (<-~), (<-=)- -- ** Multiplication- , (*~), (*=), (<*~), (<*=)- -- ** Division- , (//~), (//=), (<//~), (<//=)- -- ** Exponentiation- , (^~), (^=), (<^~), (<^=)- , (^^~), (^^=), (<^^~), (<^^=)- , (**~), (**=), (<**~), (<**=)- -- ** Logical Or- , (||~), (||=), (<||~), (<||=)- -- ** Logical And- , (&&~), (&&=), (<&&~), (<&&=)- -- ** Monoidal- , (<>~), (<>=), (<<>~), (<<>=)-- -- * Composing Indices- , (<.>), (<.), (.>)-- -- * Monadic Assignment- , (<~), (<<~)-- -- * Zippers- , (:>)(), (:>>)()-- -- * Cons and Snoc- , (<|), (|>)+ -- * "Control.Lens.Setter"+ , (%~)+ , (.~)+ , (?~)+ , (<.~)+ , (<?~)+ , (+~)+ , (*~)+ , (-~)+ , (//~)+ , (^~)+ , (^^~)+ , (**~)+ , (||~)+ , (&&~)+ , (.=)+ , (%=)+ , (?=)+ , (+=)+ , (-=)+ , (*=)+ , (//=)+ , (^=)+ , (^^=)+ , (**=)+ , (&&=)+ , (||=)+ , (<~)+ , (<.=)+ , (<?=)+ , (<>~)+ , (<>=)+ , (%@~)+ , (%@=) ) where -import Control.Lens.Action-import Control.Lens.Combinators-import Control.Lens.Cons-import Control.Lens.Fold-import Control.Lens.Getter-import Control.Lens.Indexed-import Control.Lens.Lens-import Control.Lens.Review-import Control.Lens.Setter-import Control.Lens.Zipper--#ifdef HLINT-{-# ANN module "HLint: ignore Use import/export shortcut" #-}-#endif+import Control.Lens
src/Control/Lens/Plated.hs view
@@ -1,11 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-#ifdef DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures #-}-#endif+ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell #endif@@ -69,6 +68,7 @@ , contexts, contextsOf, contextsOn, contextsOnOf , holes, holesOn, holesOnOf , para, paraOf+ , (...) -- * Compos -- $compos@@ -88,9 +88,7 @@ import Control.Lens.Setter import Control.Lens.Traversal import qualified Language.Haskell.TH as TH-#ifdef DEFAULT_SIGNATURES import Data.Data-#endif import Data.Data.Lens import Data.Monoid import Data.Tree@@ -194,7 +192,7 @@ -- 'plate' will default to 'uniplate' and you can choose to not override -- it with your own definition. plate :: Traversal' a a-#ifdef DEFAULT_SIGNATURES+#ifndef HLINT default plate :: Data a => Traversal' a a plate = uniplate #endif@@ -206,16 +204,24 @@ instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as -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+{- Default uniplate instances -}+instance Plated TH.Exp+instance Plated TH.Dec+instance Plated TH.Con+instance Plated TH.Type #if !(MIN_VERSION_template_haskell(2,8,0))-instance Plated TH.Kind where plate = uniplate -- in 2.8 Kind is an alias for Type+instance Plated TH.Kind -- in 2.8 Kind is an alias for Type #endif-instance Plated TH.Stmt where plate = uniplate-instance Plated TH.Pat where plate = uniplate+instance Plated TH.Stmt+instance Plated TH.Pat ++infixr 9 ...+-- | Compose through a plate+(...) :: (Applicative f, Plated c) => LensLike f s t c c -> Over p f c c a b -> Over p f s t a b+l ... m = l . plate . m+{-# INLINE (...) #-}+ ------------------------------------------------------------------------------- -- Children -------------------------------------------------------------------------------@@ -527,7 +533,7 @@ -- 'holesOn' :: 'IndexedLens'' i s a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s] -- 'holesOn' :: 'IndexedTraversal'' i s a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s] -- @-holesOn :: Conjoined p => Overloading p (->) (Bazaar p a a) s t a a -> s -> [Pretext p a a t]+holesOn :: Conjoined p => Optical p (->) (Bazaar p a a) s t a a -> s -> [Pretext p a a t] holesOn = holesOf {-# INLINE holesOn #-} @@ -546,7 +552,7 @@ -- @ holesOnOf :: Conjoined p => LensLike (Bazaar p r r) s t a b- -> Overloading p (->) (Bazaar p r r) a b r r+ -> Optical p (->) (Bazaar p r r) a b r r -> s -> [Pretext p r r t] holesOnOf b l = holesOf (b . l) {-# INLINE holesOnOf #-}
src/Control/Lens/Prism.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}+ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Prism--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -26,6 +27,7 @@ , outside , aside , without+ , below , isn't -- * Common Prisms , _Left@@ -33,19 +35,23 @@ , _Just , _Nothing , _Void+ , _Show , only+ , nearly -- * Prismatic profunctors , Choice(..) ) where import Control.Applicative-import Control.Lens.Combinators import Control.Lens.Internal.Prism-import Control.Lens.Internal.Setter+import Control.Lens.Lens+import Control.Lens.Review import Control.Lens.Type import Control.Monad-import Data.Bifunctor+import Data.Functor.Identity import Data.Profunctor+import Data.Profunctor.Rep+import Data.Traversable import Data.Void #ifndef SAFE import Unsafe.Coerce@@ -71,7 +77,7 @@ ------------------------------------------------------------------------------ -- | If you see this in a signature for a function, the function is expecting a 'Prism'.-type APrism s t a b = Market a b a (Mutator b) -> Market a b s (Mutator t)+type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t) -- | @ -- type APrism' = 'Simple' 'APrism'@@ -81,10 +87,10 @@ -- | Convert 'APrism' to the pair of functions that characterize it. runPrism :: APrism s t a b -> Market a b s t #ifdef SAFE-runPrism k = case k (Market Mutator Right) of- Market bt seta -> Market (runMutator #. bt) (either (Left . runMutator) Right . seta)+runPrism k = case k (Market Identity Right) of+ Market bt seta -> Market (runIdentity #. bt) (either (Left . runIdentity) Right . seta) #else-runPrism k = unsafeCoerce (k (Market Mutator Right))+runPrism k = unsafeCoerce (k (Market Identity Right)) #endif {-# INLINE runPrism #-} @@ -117,19 +123,13 @@ -- | 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)++-- TODO: can we make this work with merely Strong?+outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r) outside k = case runPrism k of- Market bt seta -> \f tr -> f (tr.bt) <&> \ar -> either tr ar . seta+ Market bt seta -> \f ft -> f (lmap bt ft) <&> \fa -> tabulate $ either (rep ft) (rep fa) . seta {-# INLINE outside #-} --- | 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 k = case runPrism k of- Market bt seta -> prism (fmap bt) $ \(e,s) -> case seta s of- Left t -> Left (e,t)- Right a -> Right (e,a)-{-# INLINE aside #-}- -- | Given a pair of prisms, project sums. -- -- Viewing a 'Prism' as a co-'Lens', this combinator can be seen to be dual to 'Control.Lens.Lens.alongside'.@@ -143,6 +143,23 @@ Right u -> bimap Right Right (uevc u) {-# INLINE without #-} +-- | 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 k = case runPrism k of+ Market bt seta -> prism (fmap bt) $ \(e,s) -> case seta s of+ Left t -> Left (e,t)+ Right a -> Right (e,a)+{-# INLINE aside #-}++-- | 'lift' a 'Prism' through a 'Traversable' functor, giving a Prism that matches only if all the elements of the container match the 'Prism'.+below :: Traversable f => APrism' s a -> Prism' (f s) (f a)+below k = case runPrism k of+ Market bt seta -> prism (fmap bt) $ \s -> case traverse seta s of+ Left _ -> Left s+ Right t -> Right t+{-# INLINE below #-}+ -- | Check to see if this 'Prism' doesn't match. -- -- >>> isn't _Left (Right 12)@@ -150,6 +167,9 @@ -- -- >>> isn't _Left (Left 12) -- False+--+-- >>> isn't _Empty []+-- False isn't :: APrism s t a b -> s -> Bool isn't k s = case runPrism k of Market _ seta -> case seta s of@@ -272,3 +292,36 @@ only :: Eq a => a -> Prism' a () only a = prism' (\() -> a) $ guard . (a ==) {-# INLINE only #-}+++-- | This 'Prism' compares for approximate equality with a given value and a predicate for testing.+--+-- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are somewhat constrained.+--+-- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid 'Prism'.+--+-- This is useful when working with a type where you can test equality for only a subset of its+-- values, and the prism selects such a value.+nearly :: a -> (a -> Bool) -> Prism' a ()+nearly a p = prism' (\() -> a) $ guard . p+{-# INLINE nearly #-}++-- | This is an improper prism for text formatting based on 'Read' and 'Show'.+--+-- This 'Prism' is \"improper\" in the sense that it normalizes the text formatting, but round tripping+-- is idempotent given sane 'Read'/'Show' instances.+--+-- >>> _Show # 2+-- "2"+--+-- >>> "EQ" ^? _Show :: Maybe Ordering+-- Just EQ+--+-- @+-- '_Show' ≡ 'prism'' 'show' 'readMaybe'+-- @+_Show :: (Read a, Show a) => Prism' String a+_Show = prism show $ \s -> case reads s of+ [(a,"")] -> Right a+ _ -> Left s+{-# INLINE _Show #-}
src/Control/Lens/Reified.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ -- | -- Module : Control.Lens.Reified--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -11,80 +14,492 @@ ------------------------------------------------------------------------------ module Control.Lens.Reified where +import Control.Applicative+import Control.Arrow+import qualified Control.Category as Cat+import Control.Comonad+import Control.Lens.Fold+import Control.Lens.Getter+import Control.Lens.Internal.Indexed+import Control.Lens.Traversal (ignored) import Control.Lens.Type+import Control.Monad+import Control.Monad.Reader.Class+import Data.Distributive+import Data.Foldable+import Data.Functor.Compose+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Functor.Identity+import Data.Functor.Plus+import Data.Profunctor+import Data.Profunctor.Rep+import Data.Semigroup +-- $setup+-- >>> import Control.Lens+ --------------------------------------------------------------------------------- Reifying+-- Lens ------------------------------------------------------------------------------ -- | Reify a 'Lens' so it can be stored safely in a container.-newtype ReifiedLens s t a b = ReifyLens { reflectLens :: Lens s t a b }+newtype ReifiedLens s t a b = Lens { runLens :: Lens s t a b } -- | @ -- type 'ReifiedLens'' = 'Simple' 'ReifiedLens' -- @ type ReifiedLens' s a = ReifiedLens s s a a +------------------------------------------------------------------------------+-- IndexedLens+------------------------------------------------------------------------------+ -- | Reify an 'IndexedLens' so it can be stored safely in a container.-newtype ReifiedIndexedLens i s t a b = ReifyIndexedLens { reflectIndexedLens :: IndexedLens i s t a b }+newtype ReifiedIndexedLens i s t a b = IndexedLens { runIndexedLens :: IndexedLens i s t a b } -- | @ -- type 'ReifiedIndexedLens'' i = 'Simple' ('ReifiedIndexedLens' i) -- @ type ReifiedIndexedLens' i s a = ReifiedIndexedLens i s s a a +------------------------------------------------------------------------------+-- IndexedTraversal+------------------------------------------------------------------------------+ -- | Reify an 'IndexedTraversal' so it can be stored safely in a container.-newtype ReifiedIndexedTraversal i s t a b = ReifyIndexedTraversal { reflectIndexedTraversal :: IndexedTraversal i s t a b }+newtype ReifiedIndexedTraversal i s t a b = IndexedTraversal { runIndexedTraversal :: IndexedTraversal i s t a b } -- | @ -- type 'ReifiedIndexedTraversal'' i = 'Simple' ('ReifiedIndexedTraversal' i) -- @ type ReifiedIndexedTraversal' i s a = ReifiedIndexedTraversal i s s a a +------------------------------------------------------------------------------+-- Traversal+------------------------------------------------------------------------------+ -- | A form of 'Traversal' that can be stored monomorphically in a container.-data ReifiedTraversal s t a b = ReifyTraversal { reflectTraversal :: Traversal s t a b }+newtype ReifiedTraversal s t a b = Traversal { runTraversal :: Traversal s t a b } -- | @ -- type 'ReifiedTraversal'' = 'Simple' 'ReifiedTraversal' -- @ type ReifiedTraversal' s a = ReifiedTraversal s s a a +------------------------------------------------------------------------------+-- Getter+------------------------------------------------------------------------------+ -- | Reify a 'Getter' so it can be stored safely in a container.-newtype ReifiedGetter s a = ReifyGetter { reflectGetter :: Getter s a }+--+-- This can also be useful when combining getters in novel ways, as+-- 'ReifiedGetter' is isomorphic to '(->)' and provides similar instances.+--+-- >>> ("hello","world","!!!")^.runGetter ((,) <$> Getter _2 <*> Getter (_1.to length))+-- ("world",5)+newtype ReifiedGetter s a = Getter { runGetter :: Getter s a } +instance Distributive (ReifiedGetter s) where+ distribute as = Getter $ to $ \s -> fmap (\(Getter l) -> view l s) as++instance Functor (ReifiedGetter s) where+ fmap f l = Getter (runGetter l.to f)+ {-# INLINE fmap #-}++instance Semigroup s => Extend (ReifiedGetter s) where+ duplicated (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (m <> n)+ {-# INLINE duplicated #-}++instance Monoid s => Comonad (ReifiedGetter s) where+ extract (Getter l) = view l mempty+ {-# INLINE extract #-}+ duplicate (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (mappend m n)+ {-# INLINE duplicate #-}++instance Monoid s => ComonadApply (ReifiedGetter s) where+ Getter mf <@> Getter ma = Getter $ to $ \s -> view mf s (view ma s)+ {-# INLINE (<@>) #-}+ m <@ _ = m+ {-# INLINE (<@) #-}+ _ @> m = m+ {-# INLINE (@>) #-}++instance Apply (ReifiedGetter s) where+ Getter mf <.> Getter ma = Getter $ to $ \s -> view mf s (view ma s)+ {-# INLINE (<.>) #-}+ m <. _ = m+ {-# INLINE (<.) #-}+ _ .> m = m+ {-# INLINE (.>) #-}++instance Applicative (ReifiedGetter s) where+ pure a = Getter $ to $ \_ -> a+ {-# INLINE pure #-}+ Getter mf <*> Getter ma = Getter $ to $ \s -> view mf s (view ma s)+ {-# INLINE (<*>) #-}+ m <* _ = m+ {-# INLINE (<*) #-}+ _ *> m = m+ {-# INLINE (*>) #-}++instance Bind (ReifiedGetter s) where+ Getter ma >>- f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s+ {-# INLINE (>>-) #-}++instance Monad (ReifiedGetter s) where+ return a = Getter $ to $ \_ -> a+ {-# INLINE return #-}+ Getter ma >>= f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s+ {-# INLINE (>>=) #-}++instance MonadReader s (ReifiedGetter s) where+ ask = Getter id+ {-# INLINE ask #-}+ local f m = Getter (to f . runGetter m)+ {-# INLINE local #-}++instance Profunctor ReifiedGetter where+ dimap f g l = Getter $ to f.runGetter l.to g+ {-# INLINE dimap #-}+ lmap g l = Getter $ to g.runGetter l+ {-# INLINE lmap #-}+ rmap f l = Getter $ runGetter l.to f+ {-# INLINE rmap #-}++instance Corepresentable ReifiedGetter where+ type Corep ReifiedGetter = Identity+ cotabulate f = Getter $ to (f . Identity)+ corep (Getter l) = view l . runIdentity++instance Representable ReifiedGetter where+ type Rep ReifiedGetter = Identity+ tabulate f = Getter $ to (runIdentity . f)+ rep (Getter l) = Identity . view l++instance Conjoined ReifiedGetter++instance Strong ReifiedGetter where+ first' l = Getter $ \f (s,c) ->+ coerce $ runGetter l (dimap (flip (,) c) coerce f) s+ {-# INLINE first' #-}+ second' l = Getter $ \f (c,s) ->+ coerce $ runGetter l (dimap ((,) c) coerce f) s+ {-# INLINE second' #-}++instance Choice ReifiedGetter where+ left' l = Getter $ to $ left' $ view $ runGetter l+ {-# INLINE left' #-}+ right' l = Getter $ to $ right' $ view $ runGetter l+ {-# INLINE right' #-}++instance Cat.Category ReifiedGetter where+ id = Getter id+ l . r = Getter (runGetter r.runGetter l)+ {-# INLINE (.) #-}++instance Arrow ReifiedGetter where+ arr f = Getter (to f)+ {-# INLINE arr #-}+ first l = Getter $ to $ first $ view $ runGetter l+ {-# INLINE first #-}+ second l = Getter $ to $ second $ view $ runGetter l+ {-# INLINE second #-}+ Getter l *** Getter r = Getter $ to $ view l *** view r+ {-# INLINE (***) #-}+ Getter l &&& Getter r = Getter $ to $ view l &&& view r+ {-# INLINE (&&&) #-}++instance ArrowApply ReifiedGetter where+ app = Getter $ to $ \(Getter bc, b) -> view bc b+ {-# INLINE app #-}++instance ArrowChoice ReifiedGetter where+ left l = Getter $ to $ left $ view $ runGetter l+ {-# INLINE left #-}+ right l = Getter $ to $ right $ view $ runGetter l+ {-# INLINE right #-}+ Getter l +++ Getter r = Getter $ to $ view l +++ view r+ {-# INLINE (+++) #-}+ Getter l ||| Getter r = Getter $ to $ view l ||| view r+ {-# INLINE (|||) #-}++instance ArrowLoop ReifiedGetter where+ loop l = Getter $ to $ loop $ view $ runGetter l+ {-# INLINE loop #-}++------------------------------------------------------------------------------+-- IndexedGetter+------------------------------------------------------------------------------+ -- | Reify an 'IndexedGetter' so it can be stored safely in a container.-newtype ReifiedIndexedGetter i s a = ReifyIndexedGetter { reflectIndexedGetter :: IndexedGetter i s a }+newtype ReifiedIndexedGetter i s a = IndexedGetter { runIndexedGetter :: IndexedGetter i s a } +instance Profunctor (ReifiedIndexedGetter i) where+ dimap f g l = IndexedGetter (to f . runIndexedGetter l . to g)+ {-# INLINE dimap #-}++instance Representable (ReifiedIndexedGetter i) where+ type Rep (ReifiedIndexedGetter i) = (,) i+ tabulate f = IndexedGetter $ ito f+ {-# INLINE tabulate #-}+ rep = iview . runIndexedGetter+ {-# INLINE rep #-}++instance Strong (ReifiedIndexedGetter i) where+ first' l = IndexedGetter $ \f (s,c) ->+ coerce $ runIndexedGetter l (dimap (flip (,) c) coerce f) s+ {-# INLINE first' #-}+ second' l = IndexedGetter $ \f (c,s) ->+ coerce $ runIndexedGetter l (dimap ((,) c) coerce f) s+ {-# INLINE second' #-}++instance Functor (ReifiedIndexedGetter i s) where+ fmap f l = IndexedGetter (runIndexedGetter l.to f)+ {-# INLINE fmap #-}++instance Semigroup i => Apply (ReifiedIndexedGetter i s) where+ IndexedGetter mf <.> IndexedGetter ma = IndexedGetter $ \k s ->+ case iview mf s of+ (i, f) -> case iview ma s of+ (j, a) -> coerce $ indexed k (i <> j) (f a)+ {-# INLINE (<.>) #-}++------------------------------------------------------------------------------+-- Fold+------------------------------------------------------------------------------+ -- | Reify a 'Fold' so it can be stored safely in a container.-newtype ReifiedFold s a = ReifyFold { reflectFold :: Fold s a }+--+-- This can also be useful for creatively combining folds as+-- @'ReifiedFold' s@ is isomorphic to @ReaderT s []@ and provides similar+-- instances.+--+-- >>> ("hello","world")^..runFold ((,) <$> Fold _2 <*> Fold both)+-- [("world","hello"),("world","world")]+newtype ReifiedFold s a = Fold { runFold :: Fold s a } +instance Profunctor ReifiedFold where+ dimap f g l = Fold (to f . runFold l . to g)+ {-# INLINE dimap #-}+ rmap g l = Fold (runFold l . to g)+ {-# INLINE rmap #-}+ lmap f l = Fold (to f . runFold l)+ {-# INLINE lmap #-}++instance Representable ReifiedFold where+ type Rep ReifiedFold = []+ tabulate f = Fold (folding f)+ rep = toListOf . runFold++instance Strong ReifiedFold where+ first' l = Fold $ \f (s,c) ->+ coerce $ runFold l (dimap (flip (,) c) coerce f) s+ {-# INLINE first' #-}+ second' l = Fold $ \f (c,s) ->+ coerce $ runFold l (dimap ((,) c) coerce f) s+ {-# INLINE second' #-}++instance Choice ReifiedFold where+ left' (Fold l) = Fold $ folding $ \esc -> case esc of+ Left s -> Left <$> toListOf l s+ Right c -> [Right c]+ {-# INLINE left' #-}+ right' (Fold l) = Fold $ folding $ \ecs -> case ecs of+ Left c -> [Left c]+ Right s -> Right <$> toListOf l s+ {-# INLINE right' #-}++instance Cat.Category ReifiedFold where+ id = Fold id+ l . r = Fold (runFold r . runFold l)+ {-# INLINE (.) #-}++instance Arrow ReifiedFold where+ arr f = Fold (to f)+ {-# INLINE arr #-}+ first = first'+ {-# INLINE first #-}+ second = second'+ {-# INLINE second #-}+ Fold l *** Fold r = Fold $ folding $ \(x,y) -> (,) <$> toListOf l x <*> toListOf r y+ {-# INLINE (***) #-}+ Fold l &&& Fold r = Fold $ folding $ \x -> (,) <$> toListOf l x <*> toListOf r x+ {-# INLINE (&&&) #-}++instance ArrowChoice ReifiedFold where+ left = left'+ {-# INLINE left #-}+ right = right'+ {-# INLINE right #-}++instance ArrowApply ReifiedFold where+ app = Fold $ folding $ \(Fold bc, b) -> toListOf bc b+ {-# INLINE app #-}++instance Functor (ReifiedFold s) where+ fmap f l = Fold (runFold l.to f)+ {-# INLINE fmap #-}++instance Apply (ReifiedFold s) where+ Fold mf <.> Fold ma = Fold $ folding $ \s -> toListOf mf s <.> toListOf ma s+ {-# INLINE (<.>) #-}+ Fold mf <. Fold ma = Fold $ folding $ \s -> toListOf mf s <. toListOf ma s+ {-# INLINE (<.) #-}+ Fold mf .> Fold ma = Fold $ folding $ \s -> toListOf mf s .> toListOf ma s+ {-# INLINE (.>) #-}++instance Applicative (ReifiedFold s) where+ pure a = Fold $ folding $ \_ -> [a]+ {-# INLINE pure #-}+ Fold mf <*> Fold ma = Fold $ folding $ \s -> toListOf mf s <*> toListOf ma s+ {-# INLINE (<*>) #-}+ Fold mf <* Fold ma = Fold $ folding $ \s -> toListOf mf s <* toListOf ma s+ {-# INLINE (<*) #-}+ Fold mf *> Fold ma = Fold $ folding $ \s -> toListOf mf s *> toListOf ma s+ {-# INLINE (*>) #-}++instance Alternative (ReifiedFold s) where+ empty = Fold ignored+ {-# INLINE empty #-}+ Fold ma <|> Fold mb = Fold $ folding (\s -> toListOf ma s ++ toListOf mb s)+ {-# INLINE (<|>) #-}++instance Bind (ReifiedFold s) where+ Fold ma >>- f = Fold $ folding $ \s -> toListOf ma s >>- \a -> toListOf (runFold (f a)) s+ {-# INLINE (>>-) #-}++instance Monad (ReifiedFold s) where+ return a = Fold $ folding $ \_ -> [a]+ {-# INLINE return #-}+ Fold ma >>= f = Fold $ folding $ \s -> toListOf ma s >>= \a -> toListOf (runFold (f a)) s+ {-# INLINE (>>=) #-}++instance MonadPlus (ReifiedFold s) where+ mzero = empty+ {-# INLINE mzero #-}+ mplus = (<|>)+ {-# INLINE mplus #-}++instance MonadReader s (ReifiedFold s) where+ ask = Fold id+ {-# INLINE ask #-}+ local f m = Fold (to f . runFold m)+ {-# INLINE local #-}++instance Semigroup (ReifiedFold s a) where+ (<>) = (<|>)+ {-# INLINE (<>) #-}++instance Monoid (ReifiedFold s a) where+ mempty = Fold ignored+ {-# INLINE mempty #-}+ mappend = (<|>)+ {-# INLINE mappend #-}++instance Alt (ReifiedFold s) where+ (<!>) = (<|>)+ {-# INLINE (<!>) #-}++instance Plus (ReifiedFold s) where+ zero = Fold ignored+ {-# INLINE zero #-}++------------------------------------------------------------------------------+-- IndexedFold+------------------------------------------------------------------------------++newtype ReifiedIndexedFold i s a = IndexedFold { runIndexedFold :: IndexedFold i s a }++instance Semigroup (ReifiedIndexedFold i s a) where+ (<>) = (<!>)+ {-# INLINE (<>) #-}++instance Monoid (ReifiedIndexedFold i s a) where+ mempty = IndexedFold ignored+ {-# INLINE mempty #-}+ mappend = (<!>)+ {-# INLINE mappend #-}++instance Alt (ReifiedIndexedFold i s) where+ IndexedFold ma <!> IndexedFold mb = IndexedFold $+ ifolding $ \s -> itoListOf ma s ++ itoListOf mb s+ {-# INLINE (<!>) #-}++instance Plus (ReifiedIndexedFold i s) where+ zero = IndexedFold ignored+ {-# INLINE zero #-}++instance Functor (ReifiedIndexedFold i s) where+ fmap f l = IndexedFold (runIndexedFold l . to f)+ {-# INLINE fmap #-}++instance Profunctor (ReifiedIndexedFold i) where+ dimap f g l = IndexedFold (to f . runIndexedFold l . to g)+ {-# INLINE dimap #-}+ lmap f l = IndexedFold (to f . runIndexedFold l)+ {-# INLINE lmap #-}+ rmap g l = IndexedFold (runIndexedFold l . to g)+ {-# INLINE rmap #-}++instance Representable (ReifiedIndexedFold i) where+ type Rep (ReifiedIndexedFold i) = Compose [] ((,) i)+ tabulate k = IndexedFold $ \f -> coerce . traverse_ (coerce . uncurry (indexed f)) . getCompose . k+ {-# INLINE tabulate #-}+ rep (IndexedFold l) = Compose . itoListOf l+ {-# INLINE rep #-}++instance Strong (ReifiedIndexedFold i) where+ first' l = IndexedFold $ \f (s,c) ->+ coerce $ runIndexedFold l (dimap (flip (,) c) coerce f) s+ {-# INLINE first' #-}+ second' l = IndexedFold $ \f (c,s) ->+ coerce $ runIndexedFold l (dimap ((,) c) coerce f) s+ {-# INLINE second' #-}++------------------------------------------------------------------------------+-- Setter+------------------------------------------------------------------------------+ -- | 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 }+newtype ReifiedSetter s t a b = Setter { runSetter :: Setter s t a b } -- | @ -- type 'ReifiedSetter'' = 'Simple' 'ReifiedSetter' -- @ type ReifiedSetter' s a = ReifiedSetter s s a a +------------------------------------------------------------------------------+-- IndexedSetter+------------------------------------------------------------------------------+ -- | Reify an 'IndexedSetter' so it can be stored safely in a container. newtype ReifiedIndexedSetter i s t a b =- ReifyIndexedSetter { reflectIndexedSetter :: IndexedSetter i s t a b }+ IndexedSetter { runIndexedSetter :: IndexedSetter i s t a b } -- | @ -- type 'ReifiedIndexedSetter'' i = 'Simple' ('ReifiedIndexedSetter' i) -- @ type ReifiedIndexedSetter' i s a = ReifiedIndexedSetter i s s a a +------------------------------------------------------------------------------+-- Iso+------------------------------------------------------------------------------+ -- | Reify an 'Iso' so it can be stored safely in a container.-newtype ReifiedIso s t a b = ReifyIso { reflectIso :: Iso s t a b }+newtype ReifiedIso s t a b = Iso { runIso :: Iso s t a b } -- | @ -- type 'ReifiedIso'' = 'Simple' 'ReifiedIso' -- @ type ReifiedIso' s a = ReifiedIso s s a a +------------------------------------------------------------------------------+-- Prism+------------------------------------------------------------------------------+ -- | Reify a 'Prism' so it can be stored safely in a container.-newtype ReifiedPrism s t a b = ReifyPrism { reflectPrism :: Prism s t a b }+newtype ReifiedPrism s t a b = Prism { runPrism :: Prism s t a b } -- | @ -- type 'ReifiedPrism'' = 'Simple' 'ReifiedPrism'
src/Control/Lens/Review.hs view
@@ -6,7 +6,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Review--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -21,6 +21,7 @@ Review, Review' , AReview, AReview' , unto+ , un , re , review, reviews , reuse, reuses@@ -40,6 +41,7 @@ import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Unsafe+import Data.Tagged import Data.Void -- $setup@@ -61,14 +63,14 @@ -- -- You can generate a 'Review' by using 'unto'. You can also use any 'Prism' or 'Iso' -- directly as a 'Review'.-type Review s t a b = forall p f. (Profunctor p, Bifunctor p, Settable f) => Overloaded p f s t a b+type Review s t a b = forall p f. (Profunctor p, Bifunctor p, Settable f) => Optic p f s t a b -- | A 'Simple' 'Review' type Review' t b = Review t t b b -- | If you see this in a signature for a function, the function is expecting a 'Review' -- (in practice, this usually means a 'Prism').-type AReview s t a b = Overloaded Reviewed Identity s t a b+type AReview s t a b = Optic Tagged Identity s t a b -- | A 'Simple' 'AReview' type AReview' t b = AReview t t b b@@ -78,10 +80,26 @@ -- @ -- 'unto' :: (b -> t) -> 'Review'' t b -- @-unto :: (Profunctor p, Bifunctor p, Functor f) => (b -> t) -> Overloaded p f s t a b+--+-- @+-- 'unto' = 'un' . 'to'+-- @+unto :: (Profunctor p, Bifunctor p, Functor f) => (b -> t) -> Optic p f s t a b unto f = first absurd . lmap absurd . rmap (fmap f) {-# INLINE unto #-} +-- | Turn a 'Getter' around to get a 'Review'+--+-- @+-- 'un' = 'unto' . 'view'+-- 'unto' = 'un' . 'to'+-- @+--+-- >>> un (to length) # [1,2,3]+-- 3+un :: (Profunctor p, Bifunctor p, Functor f) => Getting a s a -> Optic' p f a s+un = unto . view+ -- | 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@@ -105,7 +123,7 @@ -- 're' :: 'Iso' s t a b -> 'Getter' b t -- @ re :: AReview s t a b -> Getter b t-re p = to (runIdentity #. runReviewed #. p .# Reviewed .# Identity)+re p = to (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE re #-} -- | 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.@@ -137,7 +155,7 @@ -- 'review' :: 'MonadReader' a m => 'Prism'' s a -> m s -- @ review :: MonadReader b m => AReview s t a b -> m t-review p = asks (runIdentity #. runReviewed #. p .# Reviewed .# Identity)+review p = asks (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE review #-} -- | An infix alias for 'review'.@@ -164,7 +182,7 @@ -- (#) :: 'Equality'' s a -> a -> s -- @ ( # ) :: AReview s t a b -> b -> t-( # ) p = runIdentity #. runReviewed #. p .# Reviewed .# Identity+( # ) p = runIdentity #. unTagged #. p .# Tagged .# Identity {-# INLINE ( # ) #-} -- | 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,@@ -197,7 +215,7 @@ -- 'reviews' :: 'MonadReader' a m => 'Prism'' s a -> (s -> r) -> m r -- @ reviews :: MonadReader b m => AReview s t a b -> (t -> r) -> m r-reviews p tr = asks (tr . runIdentity #. runReviewed #. p .# Reviewed .# Identity)+reviews p tr = asks (tr . runIdentity #. unTagged #. p .# Tagged .# Identity) {-# 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.@@ -218,7 +236,7 @@ -- 'reuse' :: 'MonadState' a m => 'Iso'' s a -> m s -- @ reuse :: MonadState b m => AReview s t a b -> m t-reuse p = gets (runIdentity #. runReviewed #. p .# Reviewed .# Identity)+reuse p = gets (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# 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,@@ -237,5 +255,5 @@ -- 'reuses' :: 'MonadState' a m => 'Iso'' s a -> (s -> r) -> m r -- @ reuses :: MonadState b m => AReview s t a b -> (t -> r) -> m r-reuses p tr = gets (tr . runIdentity #. runReviewed #. p .# Reviewed .# Identity)+reuses p tr = gets (tr . runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE reuses #-}
src/Control/Lens/Setter.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Setter--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -66,14 +66,17 @@ , imapOf, iover , isets , (%@~), (%@=)+ -- * Arrow operators+ , assignA -- * Exported for legible error messages , Settable- , Mutator+ , Identity(..) -- * Deprecated , mapOf ) where import Control.Applicative+import Control.Arrow import Control.Comonad import Control.Lens.Internal.Indexed import Control.Lens.Internal.Setter@@ -82,6 +85,7 @@ import Control.Monad.State.Class as State import Control.Monad.Writer.Class as Writer import Data.Functor.Contravariant+import Data.Functor.Identity import Data.Monoid import Data.Profunctor import Data.Profunctor.Rep@@ -117,9 +121,7 @@ -- -- When consuming a setter directly to perform a mapping, you can use this type, but most -- user code will not need to use this type.------ By choosing 'Mutator' rather than 'Data.Functor.Identity.Identity', we get nicer error messages.-type ASetter s t a b = (a -> Mutator b) -> s -> Mutator t+type ASetter s t a b = (a -> Identity b) -> s -> Identity t -- | This is a useful alias for use when consuming a 'Setter''. --@@ -134,9 +136,7 @@ -- -- When consuming a setter directly to perform a mapping, you can use this type, but most -- user code will not need to use this type.------ By choosing 'Mutator' rather than 'Data.Functor.Identity.Identity', we get nicer error messages.-type AnIndexedSetter i s t a b = Indexed i a (Mutator b) -> s -> Mutator t+type AnIndexedSetter i s t a b = Indexed i a (Identity b) -> s -> Identity t -- | @ -- type 'AnIndexedSetter'' i = 'Simple' ('AnIndexedSetter' i)@@ -146,7 +146,7 @@ -- | This is a convenient alias when defining highly polymorphic code that takes both -- 'ASetter' and 'AnIndexedSetter' as appropriate. If a function takes this it is -- expecting one of those two things based on context.-type Setting p s t a b = p a (Mutator b) -> s -> Mutator t+type Setting p s t a b = p a (Identity b) -> s -> Identity t -- | This is a convenient alias when defining highly polymorphic code that takes both -- 'ASetter'' and 'AnIndexedSetter'' as appropriate. If a function takes this it is@@ -221,7 +221,7 @@ -- >>> getOp (over contramapped (*5) (Op show)) 100 -- "500" ----- >>> Prelude.map ($ 1) $ over (mapped . wrapping Op . contramapped) (*12) [(*2),(+1),(^3)]+-- >>> Prelude.map ($ 1) $ over (mapped . _Unwrapping' Op . contramapped) (*12) [(*2),(+1),(^3)] -- [24,13,1728] -- contramapped :: Contravariant f => Setter (f b) (f a) a b@@ -285,24 +285,24 @@ -- @ -- 'sets' :: ((a -> b) -> s -> t) -> 'Setter' s t a b -- @-sets :: (Profunctor p, Profunctor q, Settable f) => (p a b -> q s t) -> Overloading p q f s t a b+sets :: (Profunctor p, Profunctor q, Settable f) => (p a b -> q s t) -> Optical p q f s t a b sets f g = taintedDot (f (untaintedDot g)) {-# INLINE sets #-} -- | Restore 'ASetter' to a full 'Setter'. cloneSetter :: ASetter s t a b -> Setter s t a b-cloneSetter l afb = taintedDot $ runMutator #. l (Mutator #. untaintedDot afb)+cloneSetter l afb = taintedDot $ runIdentity #. l (Identity #. untaintedDot afb) {-# INLINE cloneSetter #-} -- | Build an 'IndexPreservingSetter' from any 'Setter'. cloneIndexPreservingSetter :: ASetter s t a b -> IndexPreservingSetter s t a b cloneIndexPreservingSetter l pafb = cotabulate $ \ws ->- taintedDot runMutator $ l (\a -> Mutator (untainted (corep pafb (a <$ ws)))) (extract ws)+ taintedDot runIdentity $ l (\a -> Identity (untainted (corep pafb (a <$ ws)))) (extract ws) {-# INLINE cloneIndexPreservingSetter #-} -- | Clone an 'IndexedSetter'. cloneIndexedSetter :: AnIndexedSetter i s t a b -> IndexedSetter i s t a b-cloneIndexedSetter l pafb = taintedDot (runMutator #. l (Indexed $ \i -> Mutator #. untaintedDot (indexed pafb i)))+cloneIndexedSetter l pafb = taintedDot (runIdentity #. l (Indexed $ \i -> Identity #. untaintedDot (indexed pafb i))) {-# INLINE cloneIndexedSetter #-} -----------------------------------------------------------------------------@@ -350,7 +350,7 @@ -- 'over' :: 'ASetter' s t a b -> (a -> b) -> s -> t -- @ over :: Profunctor p => Setting p s t a b -> p a b -> s -> t-over l f = runMutator #. l (Mutator #. f)+over l f = runIdentity #. l (Identity #. f) {-# INLINE over #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter'@@ -376,7 +376,7 @@ -- 'set' :: 'Traversal' s t a b -> b -> s -> t -- @ set :: ASetter s t a b -> b -> s -> t-set l b = runMutator #. l (\_ -> Mutator b)+set l b = runIdentity #. l (\_ -> Identity b) {-# INLINE set #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter''@@ -403,7 +403,7 @@ -- 'set'' :: 'Traversal'' s a -> a -> s -> s -- @ set' :: ASetter' s a -> a -> s -> s-set' l b = runMutator #. l (\_ -> Mutator b)+set' l b = runIdentity #. l (\_ -> Identity b) {-# INLINE set' #-} -- | Modifies the target of a 'Lens' or all of the targets of a 'Setter' or@@ -671,8 +671,8 @@ -- >>> (a,b) & both **~ c -- (a**c,b**c) ----- >>> _2 **~ pi $ (1,3)--- (1,31.54428070019754)+-- >>> _2 **~ 10 $ (3,2)+-- (3,1024.0) -- -- @ -- ('**~') :: 'Floating' a => 'Setter'' s a -> a -> s -> s@@ -764,7 +764,7 @@ -- ('.=') :: 'MonadState' s m => 'Setter'' s a -> a -> m () -- @ ----- "It puts the state in the monad or it gets the hose again."+-- /It puts the state in the monad or it gets the hose again./ (.=) :: MonadState s m => ASetter s s a b -> b -> m () l .= b = State.modify (l .~ b) {-# INLINE (.=) #-}@@ -1186,6 +1186,41 @@ (%@=) :: MonadState s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m () l %@= f = State.modify (l %@~ f) {-# INLINE (%@=) #-}++------------------------------------------------------------------------------+-- Arrows+------------------------------------------------------------------------------++-- | Run an arrow command and use the output to set all the targets of+-- a 'Lens', 'Setter' or 'Traversal' to the result.+--+-- 'assignA' can be used very similarly to ('<~'), except that the type of+-- the object being modified can change; for example:+--+-- @+-- runKleisli action ((), (), ()) where+-- action = assignA _1 (Kleisli (const getVal1))+-- \>>> assignA _2 (Kleisli (const getVal2))+-- \>>> assignA _3 (Kleisli (const getVal3))+-- getVal1 :: Either String Int+-- getVal1 = ...+-- getVal2 :: Either String Bool+-- getVal2 = ...+-- getVal3 :: Either String Char+-- getVal3 = ...+-- @+--+-- has the type @'Either' 'String' ('Int', 'Bool', 'Char')@+--+-- @+-- 'assignA' :: 'Arrow' p => 'Iso' s t a b -> p s b -> p s t+-- 'assignA' :: 'Arrow' p => 'Lens' s t a b -> p s b -> p s t+-- 'assignA' :: 'Arrow' p => 'Traversal' s t a b -> p s b -> p s t+-- 'assignA' :: 'Arrow' p => 'Setter' s t a b -> p s b -> p s t+-- @+assignA :: Arrow p => ASetter s t a b -> p s b -> p s t+assignA l p = arr (flip $ set l) &&& p >>> arr (uncurry id)+{-# INLINE assignA #-} ------------------------------------------------------------------------------ -- Deprecated
− src/Control/Lens/Simple.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- |--- Module : Control.Lens.Simple--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable------ Deprecated names for simple lenses, etc.-------------------------------------------------------------------------------module Control.Lens.Simple where--import Control.Lens.Reified-import Control.Lens.Setter-import Control.Lens.Type----------------------------------------------------------------------------------- Deprecated----------------------------------------------------------------------------------- | Deprecated. Use 'Lens''.-type SimpleLens s a = Lens s s a a-{-# DEPRECATED SimpleLens "use Lens'" #-}---- | Deprecated. Use 'ReifiedLens''.-type SimpleReifiedLens s a = Lens s s a a-{-# DEPRECATED SimpleReifiedLens "use Lens'" #-}---- | Deprecated. Use 'Traversal''.-type SimpleTraversal s a = Traversal s s a a-{-# DEPRECATED SimpleTraversal "use Traversal'" #-}---- | Deprecated. Use 'ReifiedTraversal''.-type SimpleReifiedTraversal s a = ReifiedTraversal s s a a-{-# DEPRECATED SimpleReifiedTraversal "use ReifiedTraversal'" #-}---- | Deprecated. Use 'IndexedTraversal''.-type SimpleIndexedTraversal i s a = IndexedTraversal i s s a a-{-# DEPRECATED SimpleIndexedTraversal "use IndexedTraversal'" #-}---- | Deprecated. Use 'ReifiedIndexedTraversal''.-type SimpleReifiedIndexedTraversal i s a = ReifiedIndexedTraversal i s s a a-{-# DEPRECATED SimpleReifiedIndexedTraversal "use ReifiedIndexedTraversal'" #-}---- | Deprecated. Use 'Setter''.-type SimpleSetter s a = Setter s s a a-{-# DEPRECATED SimpleSetter "use Setter'" #-}---- | Deprecated. Use 'ReifiedSetter''.-type SimpleReifiedSetter s a = ReifiedSetter s s a a-{-# DEPRECATED SimpleReifiedSetter "use ReifiedSetter'" #-}---- | Deprecated. Use 'IndexedSetter''.-type SimpleIndexedSetter i s a = IndexedSetter i s s a a-{-# DEPRECATED SimpleIndexedSetter "use IndexedSetter'" #-}---- | Deprecated. Use 'ReifiedIndexedSetter''.-type SimpleReifiedIndexedSetter i s a = ReifiedIndexedSetter i s s a a-{-# DEPRECATED SimpleReifiedIndexedSetter "use ReifiedIndexedSetter'" #-}---- | Deprecated. Use 'Iso''.-type SimpleIso s a = Iso s s a a-{-# DEPRECATED SimpleIso "use Iso'" #-}---- | Deprecated. Use 'Prism''.-type SimplePrism s a = Prism s s a a-{-# DEPRECATED SimplePrism "use Prism'" #-}
src/Control/Lens/TH.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY@@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.TH--- Copyright : (C) 2012-13 Edward Kmett, Michael Sloan+-- Copyright : (C) 2012-14 Edward Kmett, Michael Sloan -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -22,14 +23,23 @@ ( -- * Constructing Lenses Automatically makeLenses, makeLensesFor- , makeClassy, makeClassyFor+ , makeClassy, makeClassyFor, makeClassy_ , makeIso , makePrisms , makeWrapped , makeFields+ -- * Constructing Lenses Given a Declaretion Quote+ , declareLenses, declareLensesFor+ , declareClassy, declareClassyFor+ , declareIso+ , declarePrisms+ , declareWrapped+ , declareFields -- * Configuring Lenses , makeLensesWith , makeFieldsWith+ , declareLensesWith+ , declareFieldsWith , defaultRules , defaultFieldRules , camelCaseFields@@ -38,6 +48,7 @@ , FieldRules(FieldRules) , lensRules , classyRules+ , classyRules_ , isoRules , lensIso , lensField@@ -58,27 +69,32 @@ ) where import Control.Applicative+import Control.Monad ((<=<), when, replicateM) #if !(MIN_VERSION_template_haskell(2,7,0)) import Control.Monad (ap) #endif+import qualified Control.Monad.Trans as Trans+import Control.Monad.Trans.Writer import Control.Lens.At-import Control.Lens.Combinators import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Iso import Control.Lens.Lens import Control.Lens.Prism+import Control.Lens.Review import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Wrapped+import Control.Lens.Internal.TH import Data.Char (toLower, toUpper, isUpper) import Data.Either (lefts)-import Data.Foldable hiding (concat)+import Data.Foldable hiding (concat, any) import Data.Function (on) import Data.List as List import Data.Map as Map hiding (toList,map,filter) import Data.Maybe as Maybe (isNothing,isJust,catMaybes,fromJust,mapMaybe)+import Data.Monoid import Data.Ord (comparing) import Data.Set as Set hiding (toList,map,filter) import Data.Set.Lens@@ -88,6 +104,8 @@ import Language.Haskell.TH.Lens #ifdef HLINT+{-# ANN module "HLint: ignore Eta reduce" #-}+{-# ANN module "HLint: ignore Use fewer imports" #-} {-# ANN module "HLint: ignore Use foldl" #-} #endif @@ -215,6 +233,9 @@ & partialLenses .~ False & buildTraversals .~ True +lensRulesFor :: [(String, String)] -> LensRules+lensRulesFor fields = lensRules & lensField .~ (`Prelude.lookup` fields)+ -- | Rules for making lenses and traversals that precompose another 'Lens'. classyRules :: LensRules classyRules = defaultRules@@ -229,6 +250,32 @@ classy n@(a:as) = Just ("Has" ++ n, toLower a:as) classy _ = Nothing +classyRulesFor+ :: (String -> Maybe (String, String)) -> [(String, String)] -> LensRules+classyRulesFor classFun fields = classyRules+ & lensClass .~ classFun+ & lensField .~ (`Prelude.lookup` fields)++underscorePrefixRules :: LensRules+underscorePrefixRules = LensRules mLowerName fld (const Nothing) $+ Set.fromList [SingletonIso, SingletonAndField, CreateClass,+ CreateInstance, BuildTraversals, GenerateSignatures]+ where+ fld cs = Just ('_':cs)++classyRules_ :: LensRules+classyRules_ = underscorePrefixRules+ & lensIso .~ const Nothing+ & handleSingletons .~ False+ & lensClass .~ classy+ & classRequired .~ True+ & partialLenses .~ False+ & buildTraversals .~ True+ where+ classy :: String -> Maybe (String, String)+ classy n@(a:as) = Just ("Has" ++ n, toLower a:as)+ classy _ = Nothing+ -- | Rules for making an isomorphism from a data type. isoRules :: LensRules isoRules = defaultRules@@ -238,7 +285,27 @@ -- | Build lenses (and traversals) with a sensible default configuration. --+-- /e.g./+-- -- @+-- data FooBar+-- = Foo { _x, _y :: 'Int' }+-- | Bar { _x :: 'Int' }+-- 'makeLenses' ''FooBar+-- @+--+-- will create+--+-- @+-- x :: 'Lens'' FooBar 'Int'+-- x f (Foo a b) = (\a\' -> Foo a\' b) \<$\> f a+-- x f (Bar a) = Bar \<$\> f a+-- y :: 'Traversal'' FooBar 'Int'+-- y f (Foo a b) = (\b\' -> Foo a b\') \<$\> f b+-- y _ c\@(Bar _) = pure c+-- @+--+-- @ -- 'makeLenses' = 'makeLensesWith' 'lensRules' -- @ makeLenses :: Name -> Q [Dec]@@ -269,6 +336,14 @@ makeClassy :: Name -> Q [Dec] makeClassy = makeLensesWith classyRules +-- | Make lenses and traversals for a type, and create a class when the type+-- has no arguments. Works the same as 'makeClassy' except that (a) it+-- expects that record field names do not begin with an underscore, (b) all+-- record fields are made into lenses, and (c) the resulting lens is prefixed+-- with an underscore.+makeClassy_ :: Name -> Q [Dec]+makeClassy_ = makeLensesWith classyRules_+ -- | Make a top level isomorphism injecting /into/ the type. -- -- The supplied name is required to be for a type with a single constructor@@ -306,7 +381,7 @@ -- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar -- @ makeLensesFor :: [(String, String)] -> Name -> Q [Dec]-makeLensesFor fields = makeLensesWith $ lensRules & lensField .~ (`Prelude.lookup` fields)+makeLensesFor fields = makeLensesWith $ lensRulesFor fields -- | Derive lenses and traversals, using a named wrapper class, and -- specifying explicit pairings of @(fieldName, traversalName)@.@@ -317,68 +392,270 @@ -- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo -- @ makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]-makeClassyFor clsName funName fields = makeLensesWith $ classyRules- & lensClass .~ const (Just (clsName,funName))- & lensField .~ (`Prelude.lookup` fields)+makeClassyFor clsName funName fields = makeLensesWith $+ classyRulesFor (const $ Just (clsName, funName)) fields -- | Build lenses with a custom configuration. makeLensesWith :: LensRules -> Name -> Q [Dec] makeLensesWith cfg nm = do inf <- reify nm case inf of- TyConI decl -> case deNewtype decl of- DataD ctx tyConName args cons _ -> case cons of- [NormalC dataConName [( _,ty)]]- | cfg^.handleSingletons -> makeIsoLenses cfg ctx tyConName args dataConName Nothing ty- [RecC dataConName [(fld,_,ty)]]- | cfg^.handleSingletons -> makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty- _ | cfg^.singletonRequired -> fail "makeLensesWith: A single-constructor single-argument data type is required"- | otherwise -> makeFieldLenses cfg ctx tyConName args cons- _ -> fail "makeLensesWith: Unsupported data type"+ TyConI decl -> makeLensesForDec cfg decl _ -> fail "makeLensesWith: Expected the name of a data type or newtype" -- | Generate a 'Prism' for each constructor of a data type.+--+-- /e.g./+--+-- @+-- data FooBarBaz a+-- = Foo Int+-- | Bar a+-- | Baz Int Char+-- makePrisms ''FooBarBaz+-- @+--+-- will create+--+-- @+-- _Foo :: Prism' (FooBarBaz a) Int+-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b+-- _Baz :: Prism' (FooBarBaz a) (Int, Char)+-- @ makePrisms :: Name -> Q [Dec] makePrisms nm = do inf <- reify nm case inf of- TyConI decl -> case deNewtype decl of- DataD ctx tyConName args cons _ ->- makePrismsForCons ctx tyConName args cons- _ -> fail "makePrisms: Unsupported data type"+ TyConI decl -> makePrismsForDec decl _ -> fail "makePrisms: Expected the name of a data type or newtype" +-- | Make lenses for all records in the given declaration quote. All record+-- syntax in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareLenses [d|+-- data Foo = Foo { fooX, fooY :: 'Int' }+-- deriving 'Show'+-- |]+-- @+--+-- will create+--+-- @+-- data Foo = Foo 'Int' 'Int' deriving 'Show'+-- fooX, fooY :: 'Lens'' Foo Int+-- @+--+-- @ declareLenses = 'declareLensesWith' ('lensRules' '&' 'lensField' '.~' 'Just') @+declareLenses :: Q [Dec] -> Q [Dec]+declareLenses = declareLensesWith (lensRules & lensField .~ Just)++-- | Similar to 'makeLensesFor', but takes a declaration quote.+declareLensesFor :: [(String, String)] -> Q [Dec] -> Q [Dec]+declareLensesFor fields = declareLensesWith $+ lensRulesFor fields & lensField .~ Just++-- | For each record in the declaration quote, make lenses and traversals for+-- it, and create a class when the type has no arguments. All record syntax+-- in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareClassy [d|+-- data Foo = Foo { fooX, fooY :: 'Int' }+-- deriving 'Show'+-- |]+-- @+--+-- will create+--+-- @+-- data Foo = Foo 'Int' 'Int' deriving 'Show'+-- class HasFoo t where+-- foo :: 'Lens'' t Foo+-- instance HasFoo Foo where foo = 'id'+-- fooX, fooY :: HasFoo t => 'Lens'' t 'Int'+-- @+--+-- @ declareClassy = 'declareLensesWith' ('classyRules' '&' 'lensField' '.~' 'Just') @+declareClassy :: Q [Dec] -> Q [Dec]+declareClassy = declareLensesWith (classyRules & lensField .~ Just)++-- | Similar to 'makeClassyFor', but takes a declaration quote.+declareClassyFor :: [(String, (String, String))] -> [(String, String)] -> Q [Dec] -> Q [Dec]+declareClassyFor classes fields = declareLensesWith $+ classyRulesFor (`Prelude.lookup`classes) fields & lensField .~ Just++-- | For each datatype declaration, make a top level isomorphism injecting+-- /into/ the type. The types are required to be for a type with a single+-- constructor that has a single argument.+--+-- All record syntax in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareIso [d|+-- newtype WrappedInt = Wrap { unrwap :: 'Int' }+-- newtype 'List' a = 'List' [a]+-- |]+-- @+--+-- will create+--+-- @+-- newtype WrappedList = Wrap 'Int'+-- newtype List a = List [a]+-- 'wrap' :: 'Iso'' Int WrappedInt+-- 'unwrap' :: 'Iso'' WrappedInt Int+-- 'list' :: 'Iso' [a] [b] ('List' a) ('List' b)+-- @+--+-- @ declareIso = 'declareLensesWith' ('isoRules' '&' 'lensField' '.~' 'Just') @+declareIso :: Q [Dec] -> Q [Dec]+declareIso = declareLensesWith $ isoRules & lensField .~ Just++-- | Generate a 'Prism' for each constructor of each data type.+--+-- /e.g./+--+-- @+-- declarePrisms [d|+-- data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }+-- |]+-- @+--+-- will create+--+-- @+-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }+-- _Lit :: 'Prism'' Exp Int+-- _Var :: 'Prism'' Exp String+-- _Lambda :: 'Prism'' Exp (String, Exp)+-- @+declarePrisms :: Q [Dec] -> Q [Dec]+declarePrisms = declareWith $ \dec -> do+ emit =<< Trans.lift (makePrismsForDec dec)+ return dec++-- | Build 'Wrapped' instance for each newtype.+declareWrapped :: Q [Dec] -> Q [Dec]+declareWrapped = declareWith $ \dec -> do+ maybeDecs <- Trans.lift (makeWrappedForDec dec)+ forM_ maybeDecs emit+ return dec++-- | @ declareFields = 'declareFieldsWith' 'defaultFieldRules' @+declareFields :: Q [Dec] -> Q [Dec]+declareFields = declareFieldsWith defaultFieldRules++-- | Declare lenses for each records in the given declarations, using the+-- specified 'LensRules'. Any record syntax in the input will be stripped+-- off.+declareLensesWith :: LensRules -> Q [Dec] -> Q [Dec]+declareLensesWith rules = declareWith $ \dec -> do+ emit =<< Trans.lift (makeLensesForDec rules dec)+ return $ stripFields dec++-- | Declare fields for each records in the given declarations, using the+-- specified 'FieldRules'. Any record syntax in the input will be stripped+-- off.+declareFieldsWith :: FieldRules -> Q [Dec] -> Q [Dec]+declareFieldsWith rules = declareWith $ \dec -> do+ emit =<< Trans.lift (makeFieldsForDec rules dec)+ return $ stripFields dec+ ----------------------------------------------------------------------------- -- Internal TH Implementation ----------------------------------------------------------------------------- --- | Transform @NewtypeD@s declarations to @DataD@s.+-- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to+-- @DataInstD@s. deNewtype :: Dec -> Dec-deNewtype (NewtypeD ctx tyConName args c d) = DataD ctx tyConName args [c] d+deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d+deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d deNewtype d = d -makePrismsForCons :: [Pred] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]-makePrismsForCons ctx tyConName args cons =- concat <$> mapM (makePrismForCon ctx tyConName args canModifyTypeVar cons) cons+makePrismsForDec :: Dec -> Q [Dec]+makePrismsForDec decl = case makeDataDecl decl of+ Just dataDecl -> makePrismsForCons dataDecl+ _ -> fail "makePrisms: Unsupported data type"++makePrismsForCons :: DataDecl -> Q [Dec]+makePrismsForCons dataDecl@(DataDecl _ _ _ _ [_]) = case constructors dataDecl of+ -- Iso promotion via tuples+ [NormalC dataConName xs] ->+ makeIsoLenses isoRules dataDecl dataConName Nothing $ map (view _2) xs+ [RecC dataConName xs] ->+ makeIsoLenses isoRules dataDecl dataConName Nothing $ map (view _3) xs+ _ ->+ fail "makePrismsForCons: A single-constructor data type is required"+makePrismsForCons dataDecl =+ concat <$> mapM (makePrismOrReviewForCon dataDecl canModifyTypeVar ) (constructors dataDecl) where- conTypeVars = map (Set.fromList . toListOf typeVars) cons+ conTypeVars = map (Set.fromList . toListOf typeVars) (constructors dataDecl) canModifyTypeVar = (`Set.member` typeVarsOnlyInOneCon) . view name typeVarsOnlyInOneCon = Set.fromList . concat . filter (\xs -> length xs == 1) . List.group . List.sort $ conTypeVars >>= toList -makePrismForCon :: [Pred] -> Name -> [TyVarBndr] -> (TyVarBndr -> Bool) -> [Con] -> Con -> Q [Dec]-makePrismForCon ctx tyConName args canModifyTypeVar allCons con = do+onlyBuildReview :: Con -> Bool+onlyBuildReview ForallC{} = True+onlyBuildReview _ = False++makePrismOrReviewForCon :: DataDecl -> (TyVarBndr -> Bool) -> Con -> Q [Dec]+makePrismOrReviewForCon dataDecl canModifyTypeVar con+ | onlyBuildReview con = makeReviewForCon dataDecl con+ | otherwise = makePrismForCon dataDecl canModifyTypeVar con++makeReviewForCon :: DataDecl -> Con -> Q [Dec]+makeReviewForCon dataDecl con = do+ let functionName = mkName ('_': nameBase dataConName)+ (dataConName, fieldTypes) = ctrNameAndFieldTypes con++ sName <- newName "s"+ aName <- newName "a"+ fieldNames <- replicateM (length fieldTypes) (newName "x")++ -- Compute the type: Constructor Constraints => Review s (Type x y z) a fieldTypes+ let s = varT sName+ t = return (fullType dataDecl (map (VarT . view name) (dataParameters dataDecl)))+ a = varT aName+ b = toTupleT (map return fieldTypes)++ (conTyVars, conCxt) = case con of ForallC x y _ -> (x,y)+ _ -> ([],[])++ functionType = forallT (map PlainTV [sName, aName] ++ conTyVars ++ dataParameters dataDecl)+ (return conCxt)+ (conT ''Review `appsT` [s,t,a,b])++ -- Compute expression: unto (\(fields) -> Con fields)+ let pat = toTupleP (map varP fieldNames)+ lam = lam1E pat (conE dataConName `appsE1` map varE fieldNames)+ body = varE 'unto `appE` lam++ Prelude.sequence+ [ sigD functionName functionType+ , funD functionName [clause [] (normalB body) []]+ ]++makePrismForCon :: DataDecl -> (TyVarBndr -> Bool) -> Con -> Q [Dec]+makePrismForCon dataDecl canModifyTypeVar con = do remitterName <- newName "remitter" reviewerName <- newName "reviewer" xName <- newName "x" let resName = mkName $ '_': nameBase dataConName varNames <- for [0..length fieldTypes -1] $ \i -> newName ('x' : show i)+ let args = dataParameters dataDecl altArgsList <- forM (view name <$> filter isAltArg args) $ \arg -> (,) arg <$> newName (nameBase arg) let altArgs = Map.fromList altArgsList hitClause = clause [conP dataConName (fmap varP varNames)] (normalB $ appE (conE 'Right) $ toTupleE $ varE <$> varNames) []- otherCons = filter (/= con) allCons+ otherCons = filter (/= con) (constructors dataDecl) missClauses | List.null otherCons = [] | Map.null altArgs = [clause [varP xName] (normalB (appE (conE 'Left) (varE xName))) []]@@ -386,16 +663,16 @@ Prelude.sequence [ sigD resName . forallT (args ++ (PlainTV <$> Map.elems altArgs))- (return $ List.nub (ctx ++ substTypeVars altArgs ctx)) $- if altArgsList == [] then+ (return $ List.nub (dataContext dataDecl ++ substTypeVars altArgs (dataContext dataDecl))) $+ if List.null altArgsList then conT ''Prism' `appsT`- [ appsT (conT tyConName) $ varT . view name <$> args+ [ return $ fullType dataDecl $ VarT . view name <$> args , toTupleT $ pure <$> fieldTypes ] else conT ''Prism `appsT`- [ appsT (conT tyConName) $ varT . view name <$> args- , appsT (conT tyConName) $ varT . view name <$> substTypeVars altArgs args+ [ return $ fullType dataDecl $ VarT . view name <$> args+ , return $ fullType dataDecl $ VarT . view name <$> substTypeVars altArgs args , toTupleT $ pure <$> fieldTypes , toTupleT $ pure <$> substTypeVars altArgs fieldTypes ]@@ -403,7 +680,7 @@ [ clause [] (normalB (appsE [varE 'prism, varE remitterName, varE reviewerName])) [ funD remitterName- [ clause [toTupleP (varP <$> varNames)] (normalB (appsE (conE dataConName : fmap varE varNames))) [] ]+ [ clause [toTupleP (varP <$> varNames)] (normalB (conE dataConName `appsE1` fmap varE varNames)) [] ] , funD reviewerName $ hitClause : missClauses ] ]@@ -427,82 +704,132 @@ varNames <- for [0 .. length fieldTypes - 1] $ \i -> newName ('x' : show i) clause [conP dataConName (fmap varP varNames)]- (normalB $ appE (conE 'Left) $ appsE (conE dataConName : fmap varE varNames))+ (normalB (appE (conE 'Left) (conE dataConName `appsE1` fmap varE varNames))) [] -toTupleT :: [TypeQ] -> TypeQ-toTupleT [x] = x-toTupleT xs = appsT (tupleT (length xs)) xs--toTupleE :: [ExpQ] -> ExpQ-toTupleE [x] = x-toTupleE xs = tupE xs--toTupleP :: [PatQ] -> PatQ-toTupleP [x] = x-toTupleP xs = tupP xs- -- | Given a set of names, build a map from those names to a set of fresh names -- based on them. freshMap :: Set Name -> Q (Map Name Name) freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n)) -makeIsoTo :: Name -> ExpQ-makeIsoTo = conE+-- i.e. AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Base.String)+-- --> (\(x, y) -> Rect x y)+makeIsoFrom :: Type -> Name -> Q ([Name], Exp)+makeIsoFrom ty conName = lam <$> deCom ty+ where+ lam (ns, e) = (ns, LamE [TupP (map VarP ns)] e)+ deCom (TupleT _) = return ([], ConE conName)+ deCom (AppT l _) = do+ (ln, l') <- deCom l+ x <- newName "x"+ return (ln ++ [x], AppE l' (VarE x))+ deCom t = fail $ "unable to create isomorphism for: " ++ show t -makeIsoFrom :: Name -> ExpQ-makeIsoFrom conName = do- b <- newName "b"- lamE [conP conName [varP b]] $ varE b+-- i.e. AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Base.String)+-- --> (\(Rect x y) -> (x, y))+makeIsoTo :: [Name] -> Name -> ExpQ+makeIsoTo ns conName = lamE [conP conName (map varP ns)]+ $ tupE $ map varE ns -makeIsoBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ-makeIsoBody lensName conName f g = funD lensName [clause [] (normalB body) []] where+makeIsoBody :: Name -> Exp -> Exp -> DecQ+makeIsoBody lensName f t = funD lensName [clause [] (normalB body) []] where body = appsE [ varE 'iso- , g conName- , f conName+ , return f+ , return t ] -makeLensBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ-makeLensBody lensName conName i o = do+makeLensBody :: Name -> Exp -> Exp -> DecQ+makeLensBody lensName 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)+ , return o+ , varE f `appE` (return i `appE` varE a) ])) []] plain :: TyVarBndr -> TyVarBndr plain (KindedTV t _) = PlainTV t plain (PlainTV t) = PlainTV t -appArgs :: Type -> [TyVarBndr] -> Type-appArgs t [] = t-appArgs t (x:xs) = appArgs (AppT t (VarT (x^.name))) xs- apps :: Type -> [Type] -> Type apps = Prelude.foldl AppT -appsT :: TypeQ -> [TypeQ] -> TypeQ-appsT = Prelude.foldl appT+makeLensesForDec :: LensRules -> Dec -> Q [Dec]+makeLensesForDec cfg decl = case makeDataDecl decl of+ Just dataDecl -> makeLensesForCons cfg dataDecl+ Nothing -> fail "makeLensesWith: Unsupported data type" +makeLensesForCons :: LensRules -> DataDecl -> Q [Dec]+makeLensesForCons cfg dataDecl = case constructors dataDecl of+ [NormalC dataConName [( _,ty)]]+ | cfg^.handleSingletons ->+ makeIsoLenses cfg dataDecl dataConName Nothing [ty]+ [RecC dataConName [(fld,_,ty)]]+ | cfg^.handleSingletons ->+ makeIsoLenses cfg dataDecl dataConName (Just fld) [ty]+ _ | cfg^.singletonRequired ->+ fail "makeLensesWith: A single-constructor single-argument data type is required"+ | otherwise ->+ makeFieldLenses cfg dataDecl++makeDataDecl :: Dec -> Maybe DataDecl+makeDataDecl dec = case deNewtype dec of+ DataD ctx tyName args cons _ -> Just DataDecl+ { dataContext = ctx+ , tyConName = Just tyName+ , dataParameters = args+ , fullType = apps $ ConT tyName+ , constructors = cons+ }+ DataInstD ctx familyName args cons _ -> Just DataDecl+ { dataContext = ctx+ , tyConName = Nothing+ , dataParameters = map PlainTV vars+ , fullType = \tys -> apps (ConT familyName) $+ substType (Map.fromList $ zip vars tys) args+ , constructors = cons+ }+ where+ -- The list of "type parameters" to a data family instance is not+ -- explicitly specified in the source. Here we define it to be+ -- the set of distinct type variables that appear in the LHS. e.g.+ --+ -- data instance F a Int (Maybe (a, b)) = G+ --+ -- has 2 type parameters: a and b.+ vars = toList $ setOf typeVars args+ _ -> Nothing++-- | A data, newtype, data instance or newtype instance declaration.+data DataDecl = DataDecl+ { dataContext :: Cxt -- ^ Datatype context.+ , tyConName :: Maybe Name+ -- ^ Type constructor name, or Nothing for a data family instance.+ , dataParameters :: [TyVarBndr] -- ^ List of type parameters+ , fullType :: [Type] -> Type+ -- ^ Create a concrete record type given a substitution to+ -- 'detaParameters'.+ , constructors :: [Con] -- ^ Constructors+ -- , derivings :: [Name] -- currently not needed+ }+ makeIsoLenses :: LensRules- -> Cxt- -> Name- -> [TyVarBndr]+ -> DataDecl -> Name -> Maybe Name- -> Type+ -> [Type] -> Q [Dec]-makeIsoLenses cfg ctx tyConName tyArgs0 dataConName maybeFieldName partTy = do- let tyArgs = map plain tyArgs0+makeIsoLenses cfg dataDecl dataConName maybeFieldName partTy = do+ let tyArgs = map plain (dataParameters dataDecl) m <- freshMap $ setOf typeVars tyArgs- let aty = partTy+ let aty = List.foldl' AppT (TupleT $ length partTy) partTy bty = substTypeVars m aty- cty = appArgs (ConT tyConName) tyArgs+ cty = fullType dataDecl $ map (VarT . view name) tyArgs dty = substTypeVars m cty- quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) (ctx ++ substTypeVars m ctx)+ quantified = ForallT (tyArgs ++ substTypeVars m tyArgs)+ (dataContext dataDecl ++ substTypeVars m (dataContext dataDecl)) maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName) lensOnly = not $ cfg^.singletonIso isoCon | lensOnly = ConT ''Lens@@ -516,7 +843,9 @@ if cfg^.simpleLenses || Map.null m then isoCon' `apps` [aty,cty] else isoCon `apps` [aty,bty,cty,dty]- body <- makeBody isoName dataConName makeIsoFrom makeIsoTo+ (ns, f) <- makeIsoFrom aty dataConName+ t <- makeIsoTo ns dataConName+ body <- makeBody isoName f t #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else@@ -530,7 +859,9 @@ if cfg^.simpleLenses || Map.null m then isoCon' `apps` [cty,aty] else isoCon `apps` [cty,dty,aty,bty]- body <- makeBody lensName dataConName makeIsoTo makeIsoFrom+ (ns, f) <- makeIsoFrom aty dataConName+ t <- makeIsoTo ns dataConName+ body <- makeBody lensName t f #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else@@ -549,7 +880,7 @@ Nothing -> funD lensName clauses where clauses = map buildClause conList- buildClause (con, fields) = do+ buildClause (con@RecC{}, fields) = do f <- newName "_f" vars <- for (con^..conNamedFields._1) $ \fld -> if fld `List.elem` fields@@ -560,7 +891,7 @@ fpats = map (varP . snd) $ lefts vars -- Lambda patterns fvals = map (appE (varE f) . varE . fst) $ lefts vars -- Functor applications conName = con^.name- recon = appsE $ conE conName : cvals+ recon = conE conName `appsE1` cvals expr | not isTraversal && length fields /= 1@@ -575,16 +906,28 @@ -- = infixE (Just $ lamE fpats recon) (varE '(<$>)) $ Just $ List.foldl1 (\l r -> infixE (Just l) (varE '(<*>)) (Just r)) fvals clause [varP f, conP conName cpats] (normalB expr) [] + -- Non-record are never the target of a generated field lens body+ buildClause (con, _fields) = do+ let fieldCount = lengthOf conFields con+ vars <- replicateM fieldCount (newName "x")+ let conName = con^.name+ expr+ | isTraversal = [| pure $(conE conName `appsE1` map varE vars) |] -- We must rebuild the value to support type changing+ | otherwise = [| error errorMsg |]+ where errorMsg = show lensName ++ ": non-record constructors require traversals to be generated"++ -- clause: _ c@Con{} = expr+ -- expr: pure c+ clause [wildP, conP conName (map varP vars)] (normalB expr) []+ makeFieldLenses :: LensRules- -> Cxt -- ^ surrounding cxt driven by the data type context- -> Name -- ^ data/newtype constructor name- -> [TyVarBndr] -- ^ args- -> [Con]+ -> DataDecl -> Q [Dec]-makeFieldLenses cfg ctx tyConName tyArgs0 cons = do- let tyArgs = map plain tyArgs0- maybeLensClass = view lensClass cfg $ nameBase tyConName+makeFieldLenses cfg dataDecl = do+ let tyArgs = map plain $ dataParameters dataDecl+ maybeLensClass = view lensClass cfg . nameBase =<< tyConName dataDecl maybeClassName = fmap (^._1.to mkName) maybeLensClass+ cons = constructors dataDecl t <- newName "t" a <- newName "a" @@ -607,7 +950,7 @@ -- Map for the polymorphic variables that are only involved in these fields, to new names for them. m <- freshMap . Set.difference varSet $ Set.fromList otherVars let aty | isJust maybeClassName = VarT t- | otherwise = appArgs (ConT tyConName) tyArgs'+ | otherwise = fullType dataDecl $ map (VarT . view name) tyArgs' bty = substTypeVars m aty dty = substTypeVars m cty @@ -615,6 +958,7 @@ relevantBndr b = s^.contains (b^.name) relevantCtx = not . Set.null . Set.intersection s . setOf typeVars tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs')+ ctx = dataContext dataDecl ps = filter relevantCtx (substTypeVars m ctx) qs = case maybeClassName of Just n | not (cfg^.createClass) -> ClassP n [VarT t] : (ctx ++ ps)@@ -669,7 +1013,7 @@ let clsName = mkName clsNameString methodName = mkName methodNameString varArgs = varT . view name <$> tyArgs- appliedCon = conT tyConName `appsT` varArgs+ appliedCon = fullType dataDecl <$> sequenceA varArgs Prelude.sequence $ filter (\_ -> cfg^.createClass) [ classD (return []) clsName (PlainTV t : tyArgs) (if List.null tyArgs then [] else [FunDep [t] (view name <$> tyArgs)]) (@@ -705,40 +1049,71 @@ makeWrapped nm = do inf <- reify nm case inf of- TyConI decl ->- case deNewtype decl of- DataD _ tyConName args [con] _ -> makeWrappedInstance tyConName args con- _ -> fail "makeWrapped: Unsupported data type"+ TyConI decl -> do+ maybeDecs <- makeWrappedForDec decl+ maybe (fail "makeWrapped: Unsupported data type") return maybeDecs _ -> fail "makeWrapped: Expected the name of a newtype or datatype" -makeWrappedInstance :: Name -> [TyVarBndr] -> Con -> DecsQ-makeWrappedInstance tyConName tyArgs con = do- let tyNames = view name <$> tyArgs+makeWrappedForDec :: Dec -> Q (Maybe [Dec])+makeWrappedForDec decl = case makeDataDecl decl of+ Just dataDecl | [con] <- constructors dataDecl+ , [field] <- toListOf (conFields._2) con+ -> do wrapped <- makeWrappedInstance dataDecl con field+ rewrapped <- makeRewrappedInstance dataDecl+ return (Just [rewrapped, wrapped])+ _ -> return Nothing - tyNameRemap <- makeNameRemap tyNames+makeRewrappedInstance :: DataDecl -> DecQ+makeRewrappedInstance dataDecl = do - (newtypeConName, fieldType) <- case ctrNameAndFieldTypes con of- (a,[b]) -> return (a,b)- _ -> fail "makeWrappedInstance: Constructor must have a single field"+ t <- varT <$> newName "t" - let outer1 = conT tyConName `appsT` fmap varT tyNames- inner1 = return fieldType+ let typeArgs = map (view name) (dataParameters dataDecl) - outer2 = conT tyConName `appsT` fmap (varT . snd) tyNameRemap- inner2 = return $ substTypeVars (Map.fromList tyNameRemap) fieldType+ typeArgs' <- do+ m <- freshMap (Set.fromList typeArgs)+ return (substTypeVars m typeArgs) - dec <- instanceD (cxt [])- (conT ''Wrapped `appsT` [inner1, inner2, outer1, outer2])- [makeIsoBody 'wrapped newtypeConName makeIsoFrom makeIsoTo]+ -- Con a b c...+ let appliedType = return (fullType dataDecl (map VarT typeArgs)) - return [dec]- where- -- Return list to preserve order, convert to Map later- makeNameRemap tyNames- = for tyNames $ \ tyName -> do- tyName1 <- newName (show tyName)- return (tyName, tyName1)+ -- Con a' b' c'...+ appliedType' = return (fullType dataDecl (map VarT typeArgs')) + -- Con a' b' c'... ~ t+ eq = equalP appliedType' t++ -- Rewrapped (Con a b c...) t+ klass = conT ''Rewrapped `appsT` [appliedType, t]++ -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t+ instanceD (cxt [eq]) klass []++makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ+makeWrappedInstance dataDecl con fieldType = do++ let conName = view name con+ let typeArgs = toListOf typeVars (dataParameters dataDecl)++ -- Con a b c...+ let appliedType = fullType dataDecl (map VarT typeArgs)++ -- type Unwrapped (Con a b c...) = $fieldType+ let unwrappedATF = tySynInstD' ''Unwrapped [return appliedType] (return fieldType)++ -- Wrapped (Con a b c...)+ let klass = conT ''Wrapped `appT` return appliedType++ -- _Wrapped' = iso (\(Con x) -> x) Con+ let wrapFun = conE conName+ let unwrapFun = newName "x" >>= \x -> lam1E (conP conName [varP x]) (varE x)+ let isoMethod = funD '_Wrapped' [clause [] (normalB [|iso $unwrapFun $wrapFun|]) []]++ -- instance Wrapped (Con a b c...) where+ -- type Unwrapped (Con a b c...) = fieldType+ -- _Wrapped' = iso (\(Con x) -> x) Con+ instanceD (cxt []) klass [unwrappedATF, isoMethod]+ #if !(MIN_VERSION_template_haskell(2,7,0)) -- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse. instance Applicative Q where@@ -767,7 +1142,7 @@ #endif data FieldRules = FieldRules- { _getPrefix :: String -> Maybe String+ { _getPrefix :: [String] -> String -> Maybe String , _rawLensNaming :: String -> String , _niceLensNaming :: String -> Maybe String , _classNaming :: String -> Maybe String@@ -789,24 +1164,38 @@ underscoreFields :: FieldRules underscoreFields = FieldRules prefix rawLens niceLens classNaming where- prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs)- prefix _ = Nothing+ prefix _ ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs)+ prefix _ _ = Nothing rawLens x = x ++ "_lens"- niceLens x = prefix x <&> \n -> drop (length n + 2) x+ niceLens x = prefix [] x <&> \n -> drop (length n + 2) x classNaming x = niceLens x <&> ("Has_" ++) --- | Field rules for fields in the form @ prefixFieldname @+-- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @+-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.+-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created. camelCaseFields :: FieldRules camelCaseFields = FieldRules prefix rawLens niceLens classNaming where- sep x = case break isUpper x of+ sepUpper x = case break isUpper x of (p, s) | List.null p || List.null s -> Nothing | otherwise -> Just (p,s)- prefix x = do ('_':xs,_) <- sep x; return xs++ prefix fields = fmap fst . sepUpper <=< dealWith_ fields+ rawLens x = x ++ "Lens"- niceLens x = overHead toLower . snd <$> sep x+ niceLens x = overHead toLower . snd <$> sepUpper x classNaming x = niceLens x <&> \ (n:ns) -> "Has" ++ toUpper n : ns + dealWith_ :: [String] -> String -> Maybe String+ dealWith_ fields field | not $ any (fst . leading_) fields = Just field+ | otherwise = if leading then Just trailing else Nothing+ where+ leading_ ('_':xs) = (True, xs)+ leading_ xs = (False, xs)+ (leading, trailing) = leading_ field+++ collectRecords :: [Con] -> [VarStrictType] collectRecords cons = rs where@@ -814,60 +1203,52 @@ rs' = List.concatMap (\(RecC _ _rs) -> _rs) recs rs = nubBy ((==) `on` (^._1)) rs' -verboseLenses :: FieldRules -> Name -> Q [Dec]-verboseLenses c src = do- rs <- do- inf <- reify src- case inf of- TyConI decl -> case deNewtype decl of- DataD _ _ _ cons _ -> do- let rs = collectRecords cons- if List.null rs- then fail "verboseLenses: Expected the name of a record type"- else return rs- _ -> fail "verboseLenses: Unsupported data type"- _ -> fail "verboseLenses: Expected the name of a data type or newtype"- flip makeLenses' src- $ mkFields c rs- & map (\(Field n _ l _ _) -> (show n, show l))+verboseLenses :: FieldRules -> Dec -> Q [Dec]+verboseLenses c decl = do+ cons <- case deNewtype decl of+ DataD _ _ _ cons _ -> return cons+ DataInstD _ _ _ cons _ -> return cons+ _ -> fail "verboseLenses: Unsupported data type"+ let rs = collectRecords cons+ if List.null rs+ then fail "verboseLenses: Expected the name of a record type"+ else flip makeLenses' decl+ $ mkFields c rs+ & map (\(Field n _ l _ _) -> (show n, show l)) where makeLenses' fields' =- makeLensesWith $ lensRules+ makeLensesForDec $ lensRules & lensField .~ (`Prelude.lookup` fields') & buildTraversals .~ False & partialLenses .~ True mkFields :: FieldRules -> [VarStrictType] -> [Field] mkFields (FieldRules prefix' raw' nice' clas') rs- = Maybe.mapMaybe namer rs+ = Maybe.mapMaybe namer fields & List.groupBy (on (==) _fieldLensPrefix)- & (\ gs -> case gs of + & (\ gs -> case gs of x:_ -> x _ -> []) where- namer (n', _, _) = do- let field = nameBase n'- rawlens = mkName (raw' field)- prefix <- prefix' field+ fields = map (nameBase . fst3) rs+ fst3 (x,_,_) = x+ namer field = do+ let rawlens = mkName (raw' field)+ prefix <- prefix' fields field nice <- mkName <$> nice' field clas <- mkName <$> clas' field return (Field (mkName field) prefix rawlens clas nice) -hasClassAndInstance :: FieldRules -> Name -> Q [Dec]-hasClassAndInstance cfg src = do+hasClassAndInstance :: FieldRules -> Dec -> Q [Dec]+hasClassAndInstance cfg decl = do c <- newName "c" e <- newName "e"- (vs,rs) <- do- inf <- reify src- case inf of- TyConI decl -> case deNewtype decl of- DataD _ _ vs cons _ -> do- let rs = collectRecords cons- if List.null rs- then fail "hasClassAndInstance: Expected the name of a record type"- else return (vs,rs)- _ -> fail "hasClassAndInstance: Unsupported data type"- _ -> fail "hasClassAndInstance: Expected the name of a data type or newtype"+ dataDecl <- case makeDataDecl decl of+ Just dataDecl -> return dataDecl+ _ -> fail "hasClassAndInstance: Unsupported data type"+ let rs = collectRecords $ constructors dataDecl+ when (List.null rs) $+ fail "hasClassAndInstance: Expected the name of a record type" fmap concat . forM (mkFields cfg rs) $ \(Field field _ fullLensName className lensName) -> do classHas <- classD (return [])@@ -883,24 +1264,118 @@ _ -> error "Cannot get fieldType" instanceHas <- instanceD (return [])- (conT className `appsT` [conT src `appsT` map (varT.view name) vs, return fieldType])+ (return $ ConT className `apps`+ [fullType dataDecl $ map (VarT . view name) (dataParameters dataDecl)+ , fieldType]) [ #ifdef INLINING inlinePragma lensName, #endif- funD lensName [ clause [] (normalB (global fullLensName)) [] ]+ funD lensName [ clause [] (normalB (varE fullLensName)) [] ] ] classAlreadyExists <- isJust `fmap` lookupTypeName (show className) return (if classAlreadyExists then [instanceHas] else [classHas, instanceHas]) -- | Make fields with the specified 'FieldRules'. makeFieldsWith :: FieldRules -> Name -> Q [Dec]-makeFieldsWith c n = liftA2 (++) (verboseLenses c n) (hasClassAndInstance c n)+makeFieldsWith c n = do+ inf <- reify n+ case inf of+ TyConI decl -> makeFieldsForDec c decl+ _ -> fail "makeFieldsWith: Expected the name of a data type or newtype" --- | @ makeFields = 'makeFieldsWith' 'defaultFieldRules' @+makeFieldsForDec :: FieldRules -> Dec -> Q [Dec]+makeFieldsForDec cfg decl = liftA2 (++)+ (verboseLenses cfg decl)+ (hasClassAndInstance cfg decl)++-- | Generate overloaded field accessors.+--+-- /e.g/+--+-- @+-- data Foo a = Foo { _fooX :: 'Int', _fooY : a }+-- newtype Bar = Bar { _barX :: 'Char' }+-- makeFields ''Foo+-- makeFields ''Bar+-- @+--+-- will create+--+-- @+-- _fooXLens :: Lens' (Foo a) Int+-- _fooYLens :: Lens (Foo a) (Foo b) a b+-- class HasX s a | s -> a where+-- x :: Lens' s a+-- instance HasX (Foo a) Int where+-- x = _fooXLens+-- class HasY s a | s -> a where+-- y :: Lens' s a+-- instance HasY (Foo a) a where+-- y = _fooYLens+-- _barXLens :: Iso' Bar Char+-- instance HasX Bar Char where+-- x = _barXLens+-- @+--+-- @+-- makeFields = 'makeFieldsWith' 'defaultFieldRules'+-- @ makeFields :: Name -> Q [Dec] makeFields = makeFieldsWith defaultFieldRules -- | @ defaultFieldRules = 'camelCaseFields' @ defaultFieldRules :: FieldRules defaultFieldRules = camelCaseFields++-- Declaretion quote stuff++declareWith :: (Dec -> Declare Dec) -> Q [Dec] -> Q [Dec]+declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)++-- | Monad for emitting top-level declarations as a side effect.+type Declare = WriterT (Endo [Dec]) Q++runDeclare :: Declare [Dec] -> Q [Dec]+runDeclare dec = do+ (out, endo) <- runWriterT dec+ return $ out ++ appEndo endo []++emit :: [Dec] -> Declare ()+emit decs = tell $ Endo (decs++)++-- | Traverse each data, newtype, data instance or newtype instance+-- declaration.+traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]+traverseDataAndNewtype f decs = traverse go decs+ where+ go dec = case dec of+ DataD{} -> f dec+ NewtypeD{} -> f dec+ DataInstD{} -> f dec+ NewtypeInstD{} -> f dec++ -- Recurse into instance declarations because they main contain+ -- associated data family instances.+ InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body++ _ -> pure dec++stripFields :: Dec -> Dec+stripFields dec = case dec of+ DataD ctx tyName tyArgs cons derivings ->+ DataD ctx tyName tyArgs (map deRecord cons) derivings+ NewtypeD ctx tyName tyArgs con derivings ->+ NewtypeD ctx tyName tyArgs (deRecord con) derivings+ DataInstD ctx tyName tyArgs cons derivings ->+ DataInstD ctx tyName tyArgs (map deRecord cons) derivings+ NewtypeInstD ctx tyName tyArgs con derivings ->+ NewtypeInstD ctx tyName tyArgs (deRecord con) derivings+ _ -> dec++deRecord :: Con -> Con+deRecord con@NormalC{} = con+deRecord con@InfixC{} = con+deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con+deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields)+ where dropFieldName (_, str, typ) = (str, typ)
src/Control/Lens/Traversal.hs view
@@ -17,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -48,10 +48,15 @@ ( -- * Traversals Traversal, Traversal'+ , Traversal1, Traversal1' , IndexedTraversal, IndexedTraversal'+ , IndexedTraversal1, IndexedTraversal1' , ATraversal, ATraversal'+ , ATraversal1, ATraversal1' , AnIndexedTraversal, AnIndexedTraversal'+ , AnIndexedTraversal1, AnIndexedTraversal1' , Traversing, Traversing'+ , Traversing1, Traversing1' -- * Traversing and Lensing , traverseOf, forOf, sequenceAOf@@ -59,12 +64,15 @@ , transposeOf , mapAccumLOf, mapAccumROf , scanr1Of, scanl1Of- , failover+ , failover, ifailover -- * Monomorphic Traversals , cloneTraversal , cloneIndexPreservingTraversal , cloneIndexedTraversal+ , cloneTraversal1+ , cloneIndexPreservingTraversal1+ , cloneIndexedTraversal1 -- * Parts and Holes , partsOf, partsOf'@@ -74,10 +82,12 @@ -- * Common Traversals , Traversable(traverse)+ , Traversable1(traverse1) , both , beside , taking , dropping+ , failing -- * Indexed Traversals @@ -86,6 +96,7 @@ , TraverseMin(..) , TraverseMax(..) , traversed+ , traversed1 , traversed64 , elementOf , element@@ -105,8 +116,8 @@ , imapAccumLOf -- * Implementation Details- , Bazaar(..)- , Bazaar'+ , Bazaar(..), Bazaar'+ , Bazaar1(..), Bazaar1' , loci , iloci ) where@@ -115,15 +126,16 @@ import Control.Applicative.Backwards import Control.Category import Control.Comonad-import Control.Lens.Combinators import Control.Lens.Fold import Control.Lens.Getter (coerced) import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed+import Control.Lens.Lens import Control.Lens.Type import Control.Monad import Control.Monad.Trans.State.Lazy+import Data.Bitraversable import Data.Functor.Compose import Data.Int import Data.IntMap as IntMap@@ -132,6 +144,7 @@ import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe+import Data.Semigroup.Traversable import Data.Tagged import Data.Traversable import Data.Tuple (swap)@@ -144,6 +157,7 @@ -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate) -- >>> import Data.Maybe (fromMaybe)+-- >>> import Debug.SimpleReflect.Vars -- >>> import Data.Void -- >>> import System.Timeout (timeout) -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force@@ -160,14 +174,32 @@ -- @ type ATraversal' s a = ATraversal s s a a ++-- | When you see this as an argument to a function, it expects a 'Traversal1'.+type ATraversal1 s t a b = LensLike (Bazaar1 (->) a b) s t a b++-- | @+-- type 'ATraversal1'' = 'Simple' 'ATraversal1'+-- @+type ATraversal1' s a = ATraversal1 s s a a+ -- | When you see this as an argument to a function, it expects an 'IndexedTraversal'. type AnIndexedTraversal i s t a b = Over (Indexed i) (Bazaar (Indexed i) a b) s t a b +-- | When you see this as an argument to a function, it expects an 'IndexedTraversal1'.+type AnIndexedTraversal1 i s t a b = Over (Indexed i) (Bazaar1 (Indexed i) a b) s t a b+ -- | @ -- type 'AnIndexedTraversal'' = 'Simple' ('AnIndexedTraversal' i) -- @ type AnIndexedTraversal' i s a = AnIndexedTraversal i s s a a +-- | @+-- type 'AnIndexedTraversal1'' = 'Simple' ('AnIndexedTraversal1' i)+-- @+type AnIndexedTraversal1' i s a = AnIndexedTraversal1 i s s a a++ -- | When you see this as an argument to a function, it expects -- -- * to be indexed if @p@ is an instance of 'Indexed' i,@@ -183,10 +215,13 @@ -- * a 'Fold' if 'f' is 'Gettable' and 'Applicative'. type Traversing p f s t a b = Over p (BazaarT p f a b) s t a b +type Traversing1 p f s t a b = Over p (BazaarT1 p f a b) s t a b+ -- | @ -- type 'Traversing'' f = 'Simple' ('Traversing' f) -- @ type Traversing' p f s a = Traversing p f s s a a+type Traversing1' p f s a = Traversing1 p f s s a a -------------------------- -- Traversal Combinators@@ -453,8 +488,17 @@ -- -- /Note:/ You should really try to maintain the invariant of the number of children in the list. --+-- >>> (a,b,c) & partsOf each .~ [x,y,z]+-- (x,y,z)+-- -- Any extras will be lost. If you do not supply enough, then the remainder will come from the original structure. --+-- >>> (a,b,c) & partsOf each .~ [w,x,y,z]+-- (w,x,y)+--+-- >>> (a,b,c) & partsOf each .~ [x,y]+-- (x,y,c)+-- -- So technically, this is only a 'Lens' if you do not change the number of results it returns. -- -- When applied to a 'Fold' the result is merely a 'Getter'.@@ -568,6 +612,18 @@ -- The resulting 'Lens', 'Getter', or 'Action' will be partial if the supplied 'Traversal' returns -- no results. --+-- >>> [1,2,3] ^. singular _head+-- 1+--+-- >>> [] ^. singular _head+-- *** Exception: singular: empty traversal+--+-- >>> Left 4 ^. singular _Left+-- 4+--+-- >>> [1..10] ^. singular (ix 7)+-- 8+-- -- @ -- 'singular' :: 'Traversal' s t a a -> 'Lens' s t a a -- 'singular' :: 'Fold' s a -> 'Getter' s a@@ -577,7 +633,7 @@ -- 'singular' :: 'IndexedMonadicFold' i m s a -> 'IndexedAction' i m s a -- @ singular :: (Conjoined p, Functor f)- => Over p (BazaarT p f a a) s t a a+ => Traversing p f s t a a -> Over p f s t a a singular l = conjoined (\afb s -> let b = l sell s in case ins b of@@ -603,7 +659,7 @@ -- 'unsafeSingular' :: 'IndexedMonadicFold' i m s a -> 'IndexedAction' i m s a -- @ unsafeSingular :: (Conjoined p, Functor f)- => Over p (BazaarT p f a b) s t a b+ => Traversing p f s t a b -> Over p f s t a b unsafeSingular l = conjoined (\afb s -> let b = inline l sell s in case ins b of@@ -654,9 +710,11 @@ -- Traversals ------------------------------------------------------------------------------ --- | Traverse both parts of a tuple with matching types.+-- | Traverse both parts of a 'Bitraversable' container with matching types. ----- >>> both *~ 10 $ (1,2)+-- Usually that type will be a pair.+--+-- >>> (1,2) & both *~ 10 -- (10,20) -- -- >>> over both length ("hello","world")@@ -664,13 +722,24 @@ -- -- >>> ("hello","world")^.both -- "helloworld"-both :: Traversal (a,a) (b,b) a b-both f ~(a,a') = (,) <$> f a <*> f a'+--+-- @+-- 'both' :: 'Traversal' (a, a) (b, b) a b+-- 'both' :: 'Traversal' ('Either' a a) ('Either' b b) a b+-- @+both :: Bitraversable r => Traversal (r a a) (r b b) a b+both f = bitraverse f f {-# INLINE both #-} --- | Apply a different 'Traversal' or 'Fold' to each side of a tuple.+-- | Apply a different 'Traversal' or 'Fold' to each side of a 'Bitraversable' container. -- -- @+-- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (r s s') (r t t') a b+-- 'beside' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s' t' a b -> 'IndexedTraversal' i (r s s') (r t t') a b+-- 'beside' :: 'IndexPreservingTraversal' s t a b -> 'IndexPreservingTraversal' s' t' a b -> 'IndexPreservingTraversal' (r s s') (r t t') a b+-- @+--+-- @ -- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Lens' s t a b -> 'Lens' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Fold' s a -> 'Fold' s' a -> 'Fold' (s,s') a@@ -699,11 +768,11 @@ -- -- >>> ("hello",["world","!!!"])^..beside id traverse -- ["hello","world","!!!"]-beside :: (Representable q, Applicative (Rep q), Applicative f)- => Overloading p q f s t a b- -> Overloading p q f s' t' a b- -> Overloading p q f (s,s') (t,t') a b-beside l r f = tabulate $ \ ~(s,s') -> liftA2 (,) <$> rep (l f) s <*> rep (r f) s'+beside :: (Representable q, Applicative (Rep q), Applicative f, Bitraversable r)+ => Optical p q f s t a b+ -> Optical p q f s' t' a b+ -> Optical p q f (r s s') (r t t') a b+beside l r f = tabulate $ getCompose #. bitraverse (Compose #. rep (l f)) (Compose #. rep (r f)) {-# INLINE beside #-} -- | Visit the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'.@@ -735,7 +804,7 @@ -- @ taking :: (Conjoined p, Applicative f) => Int- -> Over p (BazaarT p f a a) s t a a+ -> Traversing p f s t a a -> Over p f s t a a taking n l = conjoined (\ afb s -> let b = inline l sell s in outs b <$> traverse afb (take n $ ins b))@@ -813,6 +882,22 @@ cloneIndexedTraversal l f = bazaar (Indexed (indexed f)) . l sell {-# INLINE cloneIndexedTraversal #-} +-- | A 'Traversal1' is completely characterized by its behavior on a 'Bazaar1'.+cloneTraversal1 :: ATraversal1 s t a b -> Traversal1 s t a b+cloneTraversal1 l f = bazaar1 f . l sell+{-# INLINE cloneTraversal1 #-}++-- | Clone a 'Traversal1' yielding an 'IndexPreservingTraversal1' that passes through+-- whatever index it is composed with.+cloneIndexPreservingTraversal1 :: ATraversal1 s t a b -> IndexPreservingTraversal1 s t a b+cloneIndexPreservingTraversal1 l pafb = cotabulate $ \ws -> runBazaar1 (l sell (extract ws)) $ \a -> corep pafb (a <$ ws)+{-# INLINE cloneIndexPreservingTraversal1 #-}++-- | Clone an 'IndexedTraversal1' yielding an 'IndexedTraversal1' with the same index.+cloneIndexedTraversal1 :: AnIndexedTraversal1 i s t a b -> IndexedTraversal1 i s t a b+cloneIndexedTraversal1 l f = bazaar1 (Indexed (indexed f)) . l sell+{-# INLINE cloneIndexedTraversal1 #-}+ ------------------------------------------------------------------------------ -- Indexed Traversals ------------------------------------------------------------------------------@@ -828,8 +913,9 @@ -- @ -- -- @--- 'itraverseOf' :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t--- 'itraverseOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t+-- 'itraverseOf' :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t+-- 'itraverseOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t+-- 'itraverseOf' :: 'Apply' f => 'IndexedTraversal1' i s t a b -> (i -> a -> f b) -> s -> f t -- @ itraverseOf :: (Indexed i a (f b) -> s -> f t) -> (i -> a -> f b) -> s -> f t itraverseOf l = l .# Indexed@@ -843,8 +929,9 @@ -- @ -- -- @--- 'iforOf' :: 'Functor' f => 'IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t--- 'iforOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t+-- 'iforOf' :: 'Functor' f => 'IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t+-- 'iforOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t+-- 'iforOf' :: 'Apply' f => 'IndexedTraversal1' i s t a b -> s -> (i -> a -> f b) -> f t -- @ iforOf :: (Indexed i a (f b) -> s -> f t) -> s -> (i -> a -> f b) -> f t iforOf = flip . itraverseOf@@ -861,8 +948,9 @@ -- @ -- -- @--- 'imapMOf' :: 'Monad' m => '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' :: 'Monad' m => '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' :: 'Bind' m => 'IndexedTraversal1' i s t a b -> (i -> a -> m b) -> s -> m t -- @ imapMOf :: (Indexed i a (WrappedMonad m b) -> s -> WrappedMonad m t) -> (i -> a -> m b) -> s -> m t imapMOf l = mapMOf l .# Indexed@@ -926,6 +1014,11 @@ traversed = conjoined traverse (indexing traverse) {-# INLINE traversed #-} +-- | Traverse any 'Traversable1' container. This is an 'IndexedTraversal1' that is indexed by ordinal position.+traversed1 :: Traversable1 f => IndexedTraversal1 Int (f a) (f b) a b+traversed1 = conjoined traverse1 (indexing traverse1)+{-# INLINE traversed1 #-}+ -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed64 :: Traversable f => IndexedTraversal Int64 (f a) (f b) a b traversed64 = conjoined traverse (indexing64 traverse)@@ -1056,8 +1149,65 @@ -- -- >>> failover _Right (*2) (Right 4) :: Maybe (Either Int Int) -- Just (Right 8)-failover :: MonadPlus m => LensLike ((,) Any) s t a b -> (a -> b) -> s -> m t-failover l f s = case l ((,) (Any True) . f) s of- (Any True, t) -> return t- (Any False, _) -> mzero+--+-- @+-- 'failover' :: Alternative m => Traversal s t a b -> (a -> b) -> s -> m t+-- @+failover :: (Profunctor p, Alternative m) => Over p ((,) Any) s t a b -> p a b -> s -> m t+failover l pafb s = case l ((,) (Any True) `rmap` pafb) s of+ (Any True, t) -> pure t+ (Any False, _) -> Applicative.empty {-# INLINE failover #-}++-- | Try to map a function which uses the index over this 'IndexedTraversal', failing if the 'IndexedTraversal' has no targets.+--+-- @+-- 'ifailover' :: Alternative m => IndexedTraversal i s t a b -> (i -> a -> b) -> s -> m t+-- @+ifailover :: Alternative m => Over (Indexed i) ((,) Any) s t a b -> (i -> a -> b) -> s -> m t+ifailover l f = failover l (Indexed f)+{-# INLINE ifailover #-}++-- | Try the first 'Traversal' (or 'Fold'), falling back on the second 'Traversal' (or 'Fold') if it returns no entries.+--+-- This is only a valid 'Traversal' if the second 'Traversal' is disjoint from the result of the first or returns+-- exactly the same results. These conditions are trivially met when given a 'Lens', 'Iso', 'Getter', 'Prism' or \"affine\" Traversal -- one that+-- has 0 or 1 target.+--+-- Mutatis mutandis for 'Fold'.+--+-- @+-- 'failing' :: 'Traversal' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b+-- 'failing' :: 'Prism' s t a b -> 'Prism' s t a b -> 'Traversal' s t a b+-- 'failing' :: 'Fold' s a -> 'Fold' s a -> 'Fold' s a+-- @+--+-- These cases are also supported, trivially, but are boring, because the left hand side always succeeds.+--+-- @+-- 'failing' :: 'Lens' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b+-- 'failing' :: 'Iso' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b+-- 'failing' :: 'Equality' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b+-- 'failing' :: 'Getter' s a -> 'Fold' s a -> 'Fold' s a+-- @+--+-- If both of the inputs are indexed, the result is also indexed, so you can apply this to a pair of indexed+-- traversals or indexed folds, obtaining an indexed traversal or indexed fold.+--+-- @+-- 'failing' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b+-- 'failing' :: 'IndexedFold' i s a -> 'IndexedFold' i s a -> 'IndexedFold' i s a+-- @+--+-- These cases are also supported, trivially, but are boring, because the left hand side always succeeds.+--+-- @+-- 'failing' :: 'IndexedLens' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b+-- 'failing' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s a -> 'IndexedFold' i s a+-- @+failing :: (Conjoined p, Applicative f) => Traversing p f s t a b -> Traversing p f s t a b -> Over p f s t a b+failing l r pafb s = case pins b of+ [] -> runBazaarT (r sell s) pafb+ xs -> unsafeOuts b <$> traverse (corep pafb) xs+ where b = l sell s+infixl 5 `failing`
src/Control/Lens/Tuple.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}@@ -12,7 +17,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Tuple--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -34,10 +39,11 @@ ) where import Control.Applicative-import Control.Lens.Combinators-import Control.Lens.Indexed-import Control.Lens.Type+import Control.Lens.Lens import Data.Functor.Identity+import Data.Profunctor (dimap)+import Data.Proxy (Proxy (Proxy))+import GHC.Generics (Generic (..), (:*:) (..), K1 (..), M1 (..), U1 (..)) -- $setup -- >>> :set -XNoOverloadedStrings@@ -72,44 +78,50 @@ -- ... -- '_1' :: 'Lens' (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' -- @- _1 :: IndexedLens Int s t a b+ _1 :: Lens s t a b+#ifndef HLINT+ default _1 :: (Generic s, Generic t, GIxed N0 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _1 #-}+ _1 = ix proxyN0+#endif instance Field1 (Identity a) (Identity b) a b where- _1 f (Identity a) = Identity <$> indexed f (0 :: Int) a+ _1 f (Identity a) = Identity <$> f a -- | @ -- '_1' k ~(a,b) = (\\a' -> (a',b)) 'Data.Functor.<$>' k a -- @ instance Field1 (a,b) (a',b) a a' where- _1 k ~(a,b) = indexed k (0 :: Int) a <&> \a' -> (a',b)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c,d)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c,d,e)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c,d,e,f)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c,d,e,f,g)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c,d,e,f,g,h)+ _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) = indexed k (0 :: Int) a <&> \a' -> (a',b,c,d,e,f,g,h,i)+ _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.@@ -131,186 +143,358 @@ -- 'Data.Traversable.traverse' '.' '_2' :: ('Control.Applicative.Applicative' f, 'Data.Traversable.Traversable' t) => (a -> f b) -> t (s, a) -> f (t (s, b)) -- 'Control.Lens.Fold.foldMapOf' ('Data.Traversable.traverse' '.' '_2') :: ('Data.Traversable.Traversable' t, 'Data.Monoid.Monoid' m) => (s -> m) -> t (b, s) -> m -- @- _2 :: IndexedLens Int s t a b+ _2 :: Lens s t a b+#ifndef HLINT+ default _2 :: (Generic s, Generic t, GIxed N1 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _2 #-}+ _2 = ix proxyN1+#endif -- | @ -- '_2' k ~(a,b) = (\\b' -> (a,b')) 'Data.Functor.<$>' k b -- @ instance Field2 (a,b) (a,b') b b' where- _2 k ~(a,b) = indexed k (1 :: Int) b <&> \b' -> (a,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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c)+ _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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c,d)+ _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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c,d,e)+ _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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c,d,e,f)+ _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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c,d,e,f,g)+ _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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c,d,e,f,g,h)+ _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) = indexed k (1 :: Int) b <&> \b' -> (a,b',c,d,e,f,g,h,i)+ _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. class Field3 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 3rd field of a tuple.- _3 :: IndexedLens Int s t a b+ _3 :: Lens s t a b+#ifndef HLINT+ default _3 :: (Generic s, Generic t, GIxed N2 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _3 #-}+ _3 = ix proxyN2+#endif instance Field3 (a,b,c) (a,b,c') c c' where- _3 k ~(a,b,c) = indexed k (2 :: Int) c <&> \c' -> (a,b,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) = indexed k (2 :: Int) c <&> \c' -> (a,b,c',d)+ _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) = indexed k (2 :: Int) c <&> \c' -> (a,b,c',d,e)+ _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) = indexed k (2 :: Int) c <&> \c' -> (a,b,c',d,e,f)+ _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) = indexed k (2 :: Int) c <&> \c' -> (a,b,c',d,e,f,g)+ _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) = indexed k (2 :: Int) c <&> \c' -> (a,b,c',d,e,f,g,h)+ _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) = indexed k (2 :: Int) c <&> \c' -> (a,b,c',d,e,f,g,h,i)+ _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. class Field4 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 4th field of a tuple.- _4 :: IndexedLens Int s t a b+ _4 :: Lens s t a b+#ifndef HLINT+ default _4 :: (Generic s, Generic t, GIxed N3 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _4 #-}+ _4 = ix proxyN3+#endif instance Field4 (a,b,c,d) (a,b,c,d') d d' where- _4 k ~(a,b,c,d) = indexed k (3 :: Int) d <&> \d' -> (a,b,c,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) = indexed k (3 :: Int) d <&> \d' -> (a,b,c,d',e)+ _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) = indexed k (3 :: Int) d <&> \d' -> (a,b,c,d',e,f)+ _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) = indexed k (3 :: Int) d <&> \d' -> (a,b,c,d',e,f,g)+ _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) = indexed k (3 :: Int) d <&> \d' -> (a,b,c,d',e,f,g,h)+ _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) = indexed k (3 :: Int) d <&> \d' -> (a,b,c,d',e,f,g,h,i)+ _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. class Field5 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 5th field of a tuple.- _5 :: IndexedLens Int s t a b+ _5 :: Lens s t a b+#ifndef HLINT+ default _5 :: (Generic s, Generic t, GIxed N4 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _5 #-}+ _5 = ix proxyN4+#endif instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where- _5 k ~(a,b,c,d,e) = indexed k (4 :: Int) e <&> \e' -> (a,b,c,d,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) = indexed k (4 :: Int) e <&> \e' -> (a,b,c,d,e',f)+ _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) = indexed k (4 :: Int) e <&> \e' -> (a,b,c,d,e',f,g)+ _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) = indexed k (4 :: Int) e <&> \e' -> (a,b,c,d,e',f,g,h)+ _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) = indexed k (4 :: Int) e <&> \e' -> (a,b,c,d,e',f,g,h,i)+ _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. class Field6 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 6th field of a tuple.- _6 :: IndexedLens Int s t a b+ _6 :: Lens s t a b+#ifndef HLINT+ default _6 :: (Generic s, Generic t, GIxed N5 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _6 #-}+ _6 = ix proxyN5+#endif 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) = indexed k (5 :: Int) f <&> \f' -> (a,b,c,d,e,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) = indexed k (5 :: Int) f <&> \f' -> (a,b,c,d,e,f',g)+ _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) = indexed k (5 :: Int) f <&> \f' -> (a,b,c,d,e,f',g,h)+ _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) = indexed k (5 :: Int) f <&> \f' -> (a,b,c,d,e,f',g,h,i)+ _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. class Field7 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 7th field of a tuple.- _7 :: IndexedLens Int s t a b+ _7 :: Lens s t a b+#ifndef HLINT+ default _7 :: (Generic s, Generic t, GIxed N6 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _7 #-}+ _7 = ix proxyN6+#endif 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) = indexed k (6 :: Int) g <&> \g' -> (a,b,c,d,e,f,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) = indexed k (6 :: Int) g <&> \g' -> (a,b,c,d,e,f,g',h)+ _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) = indexed k (6 :: Int) g <&> \g' -> (a,b,c,d,e,f,g',h,i)+ _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. class Field8 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 8th field of a tuple.- _8 :: IndexedLens Int s t a b+ _8 :: Lens s t a b+#ifndef HLINT+ default _8 :: (Generic s, Generic t, GIxed N7 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _8 #-}+ _8 = ix proxyN7+#endif 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) = indexed k (7 :: Int) h <&> \h' -> (a,b,c,d,e,f,g,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) = indexed k (7 :: Int) h <&> \h' -> (a,b,c,d,e,f,g,h',i)+ _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. class Field9 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 9th field of a tuple.- _9 :: IndexedLens Int s t a b+ _9 :: Lens s t a b+#ifndef HLINT+ default _9 :: (Generic s, Generic t, GIxed N8 (Rep s) (Rep t) a b)+ => Lens s t a b+ {-# INLINE _9 #-}+ _9 = ix proxyN8+#endif 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) = indexed k (8 :: Int) i <&> \i' -> (a,b,c,d,e,f,g,h,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 #-}++ix :: (Generic s, Generic t, GIxed n (Rep s) (Rep t) a b) => f n -> Lens s t a b+{-# INLINE ix #-}+ix n f = fmap to . gix n f . from++type family GSize (f :: * -> *)+type instance GSize U1 = Z+type instance GSize (K1 i c) = S Z+type instance GSize (M1 i c f) = GSize f+type instance GSize (a :*: b) = Add (GSize a) (GSize b)++class GIxed n s t a b | n s -> a, n t -> b, n s b -> t, n t a -> s where+ gix :: f n -> Lens (s x) (t x) a b++instance GIxed N0 (K1 i a) (K1 i b) a b where+ {-# INLINE gix #-}+ gix _ = dimap unK1 (fmap K1)++instance GIxed n s t a b => GIxed n (M1 i c s) (M1 i c t) a b where+ {-# INLINE gix #-}+ gix n = dimap unM1 (fmap M1) . gix n++instance (p ~ GT (GSize s) n,+ p ~ GT (GSize t) n,+ GIxed' p n s s' t t' a b)+ => GIxed n (s :*: s') (t :*: t') a b where+ {-# INLINE gix #-}+ gix = gix' (Proxy :: Proxy p)++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706+-- $gixed-fundeps+-- >>> :set -XDeriveGeneric -XFlexibleInstances -XMultiParamTypeClasses+-- >>> import GHC.Generics (Generic)+-- >>> data Product a b = a :* b deriving Generic+-- >>> instance Field1 (Product a b) (Product a' b) a a'+-- >>> instance Field2 (Product a b) (Product a b') b b'+#endif++class (p ~ GT (GSize s) n,+ p ~ GT (GSize t) n)+ => GIxed' p n s s' t t' a b | p n s s' -> a+ , p n t t' -> b+ , p n s s' b -> t t'+ , p n t t' a -> s s' where+ gix' :: f p -> g n -> Lens ((s :*: s') x) ((t :*: t') x) a b++instance (GT (GSize s) n ~ T,+ GT (GSize t) n ~ T,+ GIxed n s t a b)+ => GIxed' T n s s' t s' a b where+ {-# INLINE gix' #-}+ gix' _ n f (s :*: s') = fmap (:*: s') $ gix n f s++instance (GT (GSize s) n ~ F,+ n' ~ Subtract (GSize s) n,+ GIxed n' s' t' a b)+ => GIxed' F n s s' s t' a b where+ {-# INLINE gix' #-}+ gix' _ _ f (s :*: s') = fmap (s :*:) $ gix (Proxy :: Proxy n') f s'++data Z+data S a++data T+data F++type family Add x y+type instance Add Z y = y+type instance Add (S x) y = S (Add x y)++type family Subtract x y+type instance Subtract Z x = x+type instance Subtract (S x) (S y) = Subtract x y++type family GT x y+type instance GT Z x = F+type instance GT (S x) Z = T+type instance GT (S x) (S y) = GT x y++type N0 = Z+type N1 = S N0+type N2 = S N1+type N3 = S N2+type N4 = S N3+type N5 = S N4+type N6 = S N5+type N7 = S N6+type N8 = S N7++proxyN0 :: Proxy N0+{-# INLINE proxyN0 #-}+proxyN0 = Proxy++proxyN1 :: Proxy N1+{-# INLINE proxyN1 #-}+proxyN1 = Proxy++proxyN2 :: Proxy N2+{-# INLINE proxyN2 #-}+proxyN2 = Proxy++proxyN3 :: Proxy N3+{-# INLINE proxyN3 #-}+proxyN3 = Proxy++proxyN4 :: Proxy N4+{-# INLINE proxyN4 #-}+proxyN4 = Proxy++proxyN5 :: Proxy N5+{-# INLINE proxyN5 #-}+proxyN5 = Proxy++proxyN6 :: Proxy N6+{-# INLINE proxyN6 #-}+proxyN6 = Proxy++proxyN7 :: Proxy N7+{-# INLINE proxyN7 #-}+proxyN7 = Proxy++proxyN8 :: Proxy N8+{-# INLINE proxyN8 #-}+proxyN8 = Proxy
src/Control/Lens/Type.hs view
@@ -9,7 +9,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Type--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -22,34 +22,42 @@ module Control.Lens.Type ( -- * Other- Equality, Equality'+ Equality, Equality', As , Iso, Iso' , Prism , Prism' -- * Lenses, Folds and Traversals , Lens, Lens' , Traversal, Traversal'+ , Traversal1, Traversal1' , Setter, Setter' , Getter, Fold- , Action, MonadicFold+ , Fold1+ , Action, MonadicFold, RelevantMonadicFold -- * Indexed , IndexedLens, IndexedLens' , IndexedTraversal, IndexedTraversal'+ , IndexedTraversal1, IndexedTraversal1' , IndexedSetter, IndexedSetter' , IndexedGetter, IndexedFold+ , IndexedFold1 , IndexedAction, IndexedMonadicFold+ , IndexedRelevantMonadicFold -- * Index-Preserving , IndexPreservingLens, IndexPreservingLens' , IndexPreservingTraversal, IndexPreservingTraversal'+ , IndexPreservingTraversal1, IndexPreservingTraversal1' , IndexPreservingSetter, IndexPreservingSetter' , IndexPreservingGetter, IndexPreservingFold+ , IndexPreservingFold1 , IndexPreservingAction, IndexPreservingMonadicFold+ , IndexPreservingRelevantMonadicFold -- * Common , Simple , LensLike, LensLike' , Over, Over' , IndexedLensLike, IndexedLensLike'- , Overloading, Overloading'- , Overloaded, Overloaded'+ , Optical, Optical'+ , Optic, Optic' ) where import Control.Applicative@@ -57,6 +65,7 @@ import Control.Lens.Internal.Setter import Control.Lens.Internal.Indexed import Data.Functor.Contravariant+import Data.Functor.Apply import Data.Profunctor -- $setup@@ -85,19 +94,19 @@ -- 1) You get back what you put in: -- -- @--- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l b a) ≡ b+-- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l v s) ≡ v -- @ -- -- 2) Putting back what you got doesn't change anything: -- -- @--- 'Control.Lens.Setter.set' l ('Control.Lens.Getter.view' l a) a ≡ a+-- 'Control.Lens.Setter.set' l ('Control.Lens.Getter.view' l s) s ≡ s -- @ -- -- 3) Setting twice is the same as setting once: -- -- @--- 'Control.Lens.Setter.set' l c ('Control.Lens.Setter.set' l b a) ≡ 'Control.Lens.Setter.set' l c a+-- 'Control.Lens.Setter.set' l v' ('Control.Lens.Setter.set' l v s) ≡ 'Control.Lens.Setter.set' l v' s -- @ -- -- These laws are strong enough that the 4 type parameters of a 'Lens' cannot@@ -105,9 +114,20 @@ -- it a Lens Family?\" section of -- <http://comonad.com/reader/2012/mirrored-lenses/>. ----- Every 'Lens' can be used directly as a 'Control.Lens.Setter.Setter' or--- 'Traversal'.+-- There are some emergent properties of these laws: --+-- 1) @'Control.Lens.Setter.set' l s@ must be injective for every @s@ This is a consequence of law #1+--+-- 2) @'Control.Lens.Setter.set' l@ must be surjective, because of law #2, which indicates that it is possible to obtain any 'v' from some 's' such that @'Control.Lens.Setter.set' s v = s@+--+-- 3) Given just the first two laws you can prove a weaker form of law #3 where the values @v@ that you are setting match:+--+-- @+-- 'Control.Lens.Setter.set' l v ('Control.Lens.Setter.set' l v s) ≡ 'Control.Lens.Setter.set' l v s+-- @+--+-- Every 'Lens' can be used directly as a 'Control.Lens.Setter.Setter' or 'Traversal'.+-- -- You can also use a 'Lens' for 'Control.Lens.Getter.Getting' as if it were a -- 'Fold' or 'Getter'. --@@ -183,6 +203,9 @@ -- @ type Traversal' s a = Traversal s s a a +type Traversal1 s t a b = forall f. Apply f => (a -> f b) -> s -> f t+type Traversal1' s a = Traversal1 s s a a+ -- | Every 'IndexedTraversal' is a valid 'Control.Lens.Traversal.Traversal' or -- 'Control.Lens.Fold.IndexedFold'. --@@ -197,6 +220,9 @@ -- @ type IndexedTraversal' i s a = IndexedTraversal i s s a a +type IndexedTraversal1 i s t a b = forall p f. (Indexable i p, Apply f) => p a (f b) -> s -> f t+type IndexedTraversal1' i s a = IndexedTraversal1 i s s a a+ -- | An 'IndexPreservingLens' leaves any index it is composed with alone. type IndexPreservingTraversal s t a b = forall p f. (Conjoined p, Applicative f) => p a (f b) -> p s (f t) @@ -205,6 +231,9 @@ -- @ type IndexPreservingTraversal' s a = IndexPreservingTraversal s s a a +type IndexPreservingTraversal1 s t a b = forall p f. (Conjoined p, Apply f) => p a (f b) -> p s (f t)+type IndexPreservingTraversal1' s a = IndexPreservingTraversal1 s s a a+ ------------------------------------------------------------------------------ -- Setters ------------------------------------------------------------------------------@@ -301,7 +330,7 @@ -- Prism Internals ------------------------------------------------------------------------------ --- | A 'Prism' @l@ is a 0-or-1 target 'Traversal' that can also be turned+-- | A 'Prism' @l@ is a 'Traversal' that can also be turned -- around with 'Control.Lens.Review.re' to obtain a 'Getter' in the -- opposite direction. --@@ -396,6 +425,10 @@ -- | A 'Simple' 'Equality'. type Equality' s a = Equality s s a a +-- | Composable `asTypeOf`. Useful for constraining excess+-- polymorphism, @foo . (id :: As Int) . bar@.+type As a = Equality' a a+ ------------------------------------------------------------------------------- -- Getters -------------------------------------------------------------------------------@@ -405,7 +438,7 @@ -- -- Unlike a 'Lens' a 'Getter' is read-only. Since a 'Getter' -- cannot be used to write back there are no 'Lens' laws that can be applied to--- it. In fact, it is isomorphic to an arbitrary function from @(a -> s)@.+-- it. In fact, it is isomorphic to an arbitrary function from @(s -> a)@. -- -- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold', -- since it just ignores the 'Applicative'.@@ -444,6 +477,11 @@ -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold' respectively. type IndexPreservingFold s a = forall p f. (Conjoined p, Contravariant f, Applicative f) => p a (f a) -> p s (f s) +-- | A relevant Fold (aka 'Fold1') has one or more targets.+type Fold1 s a = forall f. (Contravariant f, Apply f) => (a -> f a) -> s -> f s+type IndexedFold1 i s a = forall p f. (Indexable i p, Contravariant f, Apply f) => p a (f a) -> s -> f s+type IndexPreservingFold1 s a = forall p f. (Conjoined p, Contravariant f, Apply f) => p a (f a) -> p s (f s)+ ------------------------------------------------------------------------------- -- Actions -------------------------------------------------------------------------------@@ -476,6 +514,7 @@ -- -- You can compose a 'MonadicFold' with another 'MonadicFold' using ('Prelude..') from the @Prelude@. type MonadicFold m s a = forall f r. (Effective m r f, Applicative f) => (a -> f a) -> s -> f s+type RelevantMonadicFold m s a = forall f r. (Effective m r f, Apply f) => (a -> f a) -> s -> f s -- | An 'IndexedMonadicFold' is an 'IndexedFold' enriched with access to a 'Monad' for side-effects. --@@ -483,10 +522,12 @@ -- -- You can compose an 'IndexedMonadicFold' with another 'IndexedMonadicFold' using ('Prelude..') from the @Prelude@. type IndexedMonadicFold i m s a = forall p f r. (Indexable i p, Effective m r f, Applicative f) => p a (f a) -> s -> f s+type IndexedRelevantMonadicFold i m s a = forall p f r. (Indexable i p, Effective m r f, Apply f) => p a (f a) -> s -> f s -- | An 'IndexPreservingFold' can be used as a 'Fold', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold' respectively. type IndexPreservingMonadicFold m s a = forall p f r. (Conjoined p, Effective m r f, Applicative f) => p a (f a) -> p s (f s)+type IndexPreservingRelevantMonadicFold m s a = forall p f r. (Conjoined p, Effective m r f, Apply f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- -- Simple Overloading@@ -507,25 +548,41 @@ -- This is commonly abbreviated as a \"prime\" marker, /e.g./ 'Lens'' = 'Simple' 'Lens'. type Simple f s a = f s s a a --- | @--- type 'LensLike' f s t a b = 'Overloading' (->) (->) f s t a b+-------------------------------------------------------------------------------+-- Optics+-------------------------------------------------------------------------------++-- | A valid 'Optic' @l@ should satisfy the laws:+-- -- @-type Overloading p q f s t a b = p a (f b) -> q s (f t)+-- l 'pure' ≡ 'pure'+-- l ('Procompose' f g) = 'Procompose' (l f) (l g)+-- @+--+-- This gives rise to the laws for 'Equality', 'Iso', 'Prism', 'Lens',+-- 'Traversal', 'Traversal1', 'Setter', 'Fold', 'Fold1', and 'Getter' as well+-- along with their index-preserving variants.+--+-- @+-- type 'LensLike' f s t a b = 'Optic' (->) f s t a b+-- @+type Optic p f s t a b = p a (f b) -> p s (f t) -- | @--- type 'Overloading'' p q f s a = 'Simple' ('Overloading' p q f) s a+-- type 'Optic'' p q f s a = 'Simple' ('Optic' p q f) s a -- @-type Overloading' p q f s a = Overloading p q f s s a a+type Optic' p f s a = Optic p f s s a a -- | @--- type 'LensLike' f s t a b = 'Overloaded' (->) f s t a b+-- type 'LensLike' f s t a b = 'Optical' (->) (->) f s t a b -- @-type Overloaded p f s t a b = p a (f b) -> p s (f t)+type Optical p q f s t a b = p a (f b) -> q s (f t) -- | @--- type 'Overloaded'' p q f s a = 'Simple' ('Overloaded' p q f) s a+-- type 'Optical'' p q f s a = 'Simple' ('Optical' p q f) s a -- @-type Overloaded' p f s a = Overloaded p f s s a a+type Optical' p q f s a = Optical p q f s s a a+ -- | Many combinators that accept a 'Lens' can also accept a -- 'Traversal' in limited situations.
src/Control/Lens/Wrapped.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif@@ -13,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Wrapped--- Copyright : (C) 2012-13 Edward Kmett, Michael Sloan+-- Copyright : (C) 2012-14 Edward Kmett, Michael Sloan -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -26,15 +28,15 @@ -- they can be done with the 'Iso' directly: -- -- @--- Control.Newtype.over 'Sum' f ≡ 'wrapping' 'Sum' 'Control.Lens.Setter.%~' f--- Control.Newtype.under 'Sum' f ≡ 'unwrapping' 'Sum' 'Control.Lens.Setter.%~' f--- Control.Newtype.overF 'Sum' f ≡ 'mapping' ('wrapping' 'Sum') 'Control.Lens.Setter.%~' f--- Control.Newtype.underF 'Sum' f ≡ 'mapping' ('unwrapping' 'Sum') 'Control.Lens.Setter.%~' f+-- Control.Newtype.over 'Sum' f ≡ '_Unwrapping' 'Sum' 'Control.Lens.Setter.%~' f+-- Control.Newtype.under 'Sum' f ≡ '_Wrapping' 'Sum' 'Control.Lens.Setter.%~' f+-- Control.Newtype.overF 'Sum' f ≡ 'mapping' ('_Unwrapping' 'Sum') 'Control.Lens.Setter.%~' f+-- Control.Newtype.underF 'Sum' f ≡ 'mapping' ('_Wrapping' 'Sum') 'Control.Lens.Setter.%~' f -- @ ----- 'under' can also be used with 'wrapping' to provide the equivalent of+-- 'under' can also be used with '_Unwrapping' 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.+-- 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@@ -42,11 +44,16 @@ -- ---------------------------------------------------------------------------- module Control.Lens.Wrapped- ( Wrapped(..)- , unwrapped- , wrapped', unwrapped'- , wrapping, unwrapping- , wrappings, unwrappings+ (+ -- * Wrapping and Unwrapping monomorphically+ Wrapped(..)+ , _Unwrapped'+ , _Wrapping', _Unwrapping'+ -- * Wrapping and unwrapping polymorphically+ , Rewrapped+ , _Wrapped, _Unwrapped+ , _Wrapping, _Unwrapping+ -- * Operations , op , ala, alaf ) where@@ -56,9 +63,8 @@ import Control.Applicative.Backwards import Control.Comonad.Trans.Traced import Control.Exception-import Control.Lens.Internal.Review+import Control.Lens.Getter import Control.Lens.Iso-import Control.Lens.Review import Control.Monad.Trans.Cont import Control.Monad.Trans.Error import Control.Monad.Trans.Identity@@ -86,6 +92,7 @@ import Data.HashMap.Lazy as HashMap import Data.Map as Map import Data.Monoid+import qualified Data.Semigroup as S import Data.Sequence as Seq hiding (length) import Data.Set as Set import Data.Tagged@@ -96,259 +103,422 @@ -- | '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+class Wrapped s where+ type Unwrapped s :: *+ -- | An isomorphism between @s@ and @a@.+ _Wrapped' :: Iso' s (Unwrapped s) --- * base+-- This can be used to help inference between the wrappers+class Wrapped s => Rewrapped (s :: *) (t :: *) -instance Wrapped Bool Bool All All where- wrapped = iso All getAll- {-# INLINE wrapped #-}+class (Rewrapped s t, Rewrapped t s) => Rewrapping s t+instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t -instance Wrapped Bool Bool Any Any where- wrapped = iso Any getAny- {-# INLINE wrapped #-}+_Unwrapped' :: Wrapped s => Iso' (Unwrapped s) s+_Unwrapped' = from _Wrapped' -instance Wrapped a b (Sum a) (Sum b) where- wrapped = iso Sum getSum- {-# INLINE wrapped #-}+-- | Work under a newtype wrapper.+--+-- >>> Const "hello" & _Wrapped %~ length & getConst+-- 5+--+-- @+-- '_Wrapped' ≡ 'from' '_Unwrapped'+-- '_Unwrapped' ≡ 'from' '_Wrapped'+-- @+_Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)+_Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt+{-# INLINE _Wrapped #-} -instance Wrapped a b (Product a) (Product b) where- wrapped = iso Product getProduct- {-# INLINE wrapped #-}+_Unwrapped :: Rewrapping s t => Iso (Unwrapped t) (Unwrapped s) t s+_Unwrapped = from _Wrapped+{-# INLINE _Unwrapped #-} -instance Wrapped (a -> m b) (u -> n v) (Kleisli m a b) (Kleisli n u v) where- wrapped = iso Kleisli runKleisli- {-# INLINE wrapped #-}+-- * base -instance Wrapped (m a) (n b) (WrappedMonad m a) (WrappedMonad n b) where- wrapped = iso WrapMonad unwrapMonad- {-# INLINE wrapped #-}+instance (t ~ All) => Rewrapped All t+instance Wrapped All where+ type Unwrapped All = Bool+ _Wrapped' = iso getAll All+ {-# 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 (t ~ Any) => Rewrapped Any t+instance Wrapped Any where+ type Unwrapped Any = Bool+ _Wrapped' = iso getAny Any+ {-# INLINE _Wrapped' #-} -instance Wrapped [a] [b] (ZipList a) (ZipList b) where- wrapped = iso ZipList getZipList- {-# INLINE wrapped #-}+instance (t ~ Sum b) => Rewrapped (Sum a) t+instance Wrapped (Sum a) where+ type Unwrapped (Sum a) = a+ _Wrapped' = iso getSum Sum+ {-# INLINE _Wrapped' #-} -instance Wrapped a b (Const a x) (Const b y) where- wrapped = iso Const getConst- {-# INLINE wrapped #-}+instance (t ~ Product b) => Rewrapped (Product a) t+instance Wrapped (Product a) where+ type Unwrapped (Product a) = a+ _Wrapped' = iso getProduct Product+ {-# INLINE _Wrapped' #-} -instance Wrapped a b (Dual a) (Dual b) where- wrapped = iso Dual getDual- {-# INLINE wrapped #-}+instance (t ~ Kleisli m' a' b') => Rewrapped (Kleisli m a b) t+instance Wrapped (Kleisli m a b) where+ type Unwrapped (Kleisli m a b) = a -> m b+ _Wrapped' = iso runKleisli Kleisli+ {-# INLINE _Wrapped' #-} -instance Wrapped (a -> a) (b -> b) (Endo a) (Endo b) where- wrapped = iso Endo appEndo- {-# INLINE wrapped #-}+instance (t ~ WrappedMonad m' a') => Rewrapped (WrappedMonad m a) t+instance Wrapped (WrappedMonad m a) where+ type Unwrapped (WrappedMonad m a) = m a+ _Wrapped' = iso unwrapMonad WrapMonad+ {-# INLINE _Wrapped' #-} -instance Wrapped (Maybe a) (Maybe b) (First a) (First b) where- wrapped = iso First getFirst- {-# INLINE wrapped #-}+instance (t ~ WrappedArrow a' b' c') => Rewrapped (WrappedArrow a b c) t+instance Wrapped (WrappedArrow a b c) where+ type Unwrapped (WrappedArrow a b c) = a b c+ _Wrapped' = iso unwrapArrow WrapArrow+ {-# INLINE _Wrapped' #-} -instance Wrapped (Maybe a) (Maybe b) (Last a) (Last b) where- wrapped = iso Last getLast- {-# INLINE wrapped #-}+instance (t ~ ZipList b) => Rewrapped (ZipList a) t+instance Wrapped (ZipList a) where+ type Unwrapped (ZipList a) = [a]+ _Wrapped' = iso getZipList ZipList+ {-# 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 #-}+instance (t ~ Const a' x') => Rewrapped (Const a x) t+instance Wrapped (Const a x) where+ type Unwrapped (Const a x) = a+ _Wrapped' = iso getConst Const+ {-# INLINE _Wrapped' #-} --- * lens+instance (t ~ Dual b) => Rewrapped (Dual a) t+instance Wrapped (Dual a) where+ type Unwrapped (Dual a) = a+ _Wrapped' = iso getDual Dual+ {-# INLINE _Wrapped' #-} -instance Wrapped a b (Reviewed s a) (Reviewed t b) where- wrapped = iso Reviewed runReviewed- {-# INLINE wrapped #-}+instance (t ~ Endo b) => Rewrapped (Endo b) t+instance Wrapped (Endo a) where+ type Unwrapped (Endo a) = a -> a+ _Wrapped' = iso appEndo Endo+ {-# INLINE _Wrapped' #-} +instance (t ~ First b) => Rewrapped (First a) t+instance Wrapped (First a) where+ type Unwrapped (First a) = Maybe a+ _Wrapped' = iso getFirst First+ {-# INLINE _Wrapped' #-}++instance (t ~ Last b) => Rewrapped (Last b) t+instance Wrapped (Last a) where+ type Unwrapped (Last a) = Maybe a+ _Wrapped' = iso getLast Last+ {-# INLINE _Wrapped' #-}++instance (t ~ ArrowMonad m' a', ArrowApply m, ArrowApply m') => Rewrapped (ArrowMonad m a) t+instance ArrowApply m => Wrapped (ArrowMonad m a) where+ type Unwrapped (ArrowMonad m a) = m () a+ _Wrapped' = iso getArrowMonad ArrowMonad+ {-# INLINE _Wrapped' #-}+ -- * transformers -instance Wrapped (f a) (f' a') (Backwards f a) (Backwards f' a') where- wrapped = iso Backwards forwards- {-# INLINE wrapped #-}+instance (t ~ Backwards g b) => Rewrapped (Backwards f a) t+instance Wrapped (Backwards f a) where+ type Unwrapped (Backwards f a) = f a+ _Wrapped' = iso forwards Backwards -instance Wrapped (f (g a)) (f' (g' a')) (Compose f g a) (Compose f' g' a') where- wrapped = iso Compose getCompose- {-# INLINE wrapped #-}+instance (t ~ Compose f' g' a') => Rewrapped (Compose f g a) t+instance Wrapped (Compose f g a) where+ type Unwrapped (Compose f g a) = f (g a)+ _Wrapped' = iso getCompose Compose -instance Wrapped a a' (Constant a b) (Constant a' b') where- wrapped = iso Constant getConstant- {-# INLINE wrapped #-}+instance (t ~ Constant a' b') => Rewrapped (Constant a b) t+instance Wrapped (Constant a b) where+ type Unwrapped (Constant a b) = a+ _Wrapped' = iso getConstant Constant -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 (t ~ ContT r' m' a') => Rewrapped (ContT r m a) t+instance Wrapped (ContT r m a) where+ type Unwrapped (ContT r m a) = (a -> m r) -> m r+ _Wrapped' = iso runContT ContT -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 (t ~ ErrorT e' m' a') => Rewrapped (ErrorT e m a) t+instance Wrapped (ErrorT e m a) where+ type Unwrapped (ErrorT e m a) = m (Either e a)+ _Wrapped' = iso runErrorT ErrorT+ {-# INLINE _Wrapped' #-} -instance Wrapped a a' (Identity a) (Identity a') where- wrapped = iso Identity runIdentity- {-# INLINE wrapped #-}+instance (t ~ Identity b) => Rewrapped (Identity a) t+instance Wrapped (Identity a) where+ type Unwrapped (Identity a) = a+ _Wrapped' = iso runIdentity Identity+ {-# INLINE _Wrapped' #-} -instance Wrapped (m a) (m' a') (IdentityT m a) (IdentityT m' a') where- wrapped = iso IdentityT runIdentityT- {-# INLINE wrapped #-}+instance (t ~ IdentityT n b) => Rewrapped (IdentityT m a) t+instance Wrapped (IdentityT m a) where+ type Unwrapped (IdentityT m a) = m a+ _Wrapped' = iso runIdentityT IdentityT+ {-# INLINE _Wrapped' #-} -instance Wrapped (m [a]) (m' [a']) (ListT m a) (ListT m' a') where- wrapped = iso ListT runListT- {-# INLINE wrapped #-}+instance (t ~ ListT n b) => Rewrapped (ListT m a) t+instance Wrapped (ListT m a) where+ type Unwrapped (ListT m a) = m [a]+ _Wrapped' = iso runListT ListT+ {-# INLINE _Wrapped' #-} -instance Wrapped (m (Maybe a)) (m' (Maybe a')) (MaybeT m a) (MaybeT m' a') where- wrapped = iso MaybeT runMaybeT- {-# INLINE wrapped #-}+instance (t ~ MaybeT n b) => Rewrapped (MaybeT m a) t+instance Wrapped (MaybeT m a) where+ type Unwrapped (MaybeT m a) = m (Maybe a)+ _Wrapped' = iso runMaybeT MaybeT+ {-# 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 (t ~ ReaderT r n b) => Rewrapped (ReaderT r m a) t+instance Wrapped (ReaderT r m a) where+ type Unwrapped (ReaderT r m a) = r -> m a+ _Wrapped' = iso runReaderT ReaderT+ {-# INLINE _Wrapped' #-} -instance Wrapped (f a) (f' a') (Reverse f a) (Reverse f' a') where- wrapped = iso Reverse getReverse- {-# INLINE wrapped #-}+instance (t ~ Reverse g b) => Rewrapped (Reverse f a) t+instance Wrapped (Reverse f a) where+ type Unwrapped (Reverse f a) = f a+ _Wrapped' = iso getReverse Reverse+ {-# 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 (t ~ Lazy.RWST r' w' s' m' a') => Rewrapped (Lazy.RWST r w s m a) t+instance Wrapped (Lazy.RWST r w s m a) where+ type Unwrapped (Lazy.RWST r w s m a) = r -> s -> m (a, s, w)+ _Wrapped' = iso Lazy.runRWST Lazy.RWST+ {-# 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 (t ~ Strict.RWST r' w' s' m' a') => Rewrapped (Strict.RWST r w s m a) t+instance Wrapped (Strict.RWST r w s m a) where+ type Unwrapped (Strict.RWST r w s m a) = r -> s -> m (a, s, w)+ _Wrapped' = iso Strict.runRWST Strict.RWST+ {-# 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 (t ~ Lazy.StateT s' m' a') => Rewrapped (Lazy.StateT s m a) t+instance Wrapped (Lazy.StateT s m a) where+ type Unwrapped (Lazy.StateT s m a) = s -> m (a, s)+ _Wrapped' = iso Lazy.runStateT Lazy.StateT+ {-# 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 (t ~ Strict.StateT s' m' a') => Rewrapped (Strict.StateT s m a) t+instance Wrapped (Strict.StateT s m a) where+ type Unwrapped (Strict.StateT s m a) = s -> m (a, s)+ _Wrapped' = iso Strict.runStateT Strict.StateT+ {-# 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 (t ~ Lazy.WriterT w' m' a') => Rewrapped (Lazy.WriterT w m a) t+instance Wrapped (Lazy.WriterT w m a) where+ type Unwrapped (Lazy.WriterT w m a) = m (a, w)+ _Wrapped' = iso Lazy.runWriterT Lazy.WriterT+ {-# 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 #-}+instance (t ~ Strict.WriterT w' m' a') => Rewrapped (Strict.WriterT w m a) t+instance Wrapped (Strict.WriterT w m a) where+ type Unwrapped (Strict.WriterT w m a) = m (a, w)+ _Wrapped' = iso Strict.runWriterT Strict.WriterT+ {-# 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 (t ~ Coproduct f' g' a') => Rewrapped (Coproduct f g a) t+instance Wrapped (Coproduct f g a) where+ type Unwrapped (Coproduct f g a) = Either (f a) (g a)+ _Wrapped' = iso getCoproduct Coproduct+ {-# 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 #-}+instance (t ~ TracedT m' w' a') => Rewrapped (TracedT m w a) t+instance Wrapped (TracedT m w a) where+ type Unwrapped (TracedT m w a) = w (m -> a)+ _Wrapped' = iso runTracedT TracedT+ {-# 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- {-# INLINE wrapped #-}+instance (t ~ HashMap k' a', Hashable k, Eq k) => Rewrapped (HashMap k a) t+instance (Hashable k, Eq k) => Wrapped (HashMap k a) where+ type Unwrapped (HashMap k a) = [(k, a)]+ _Wrapped' = iso HashMap.toList HashMap.fromList+ {-# INLINE _Wrapped' #-} -- | 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- {-# INLINE wrapped #-}+instance (t ~ HashSet a', Hashable a, Eq a) => Rewrapped (HashSet a) t+instance (Hashable a, Eq a) => Wrapped (HashSet a) where+ type Unwrapped (HashSet a) = [a]+ _Wrapped' = iso HashSet.toList HashSet.fromList+ {-# INLINE _Wrapped' #-} -- * 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- {-# INLINE wrapped #-}+instance (t ~ IntMap a') => Rewrapped (IntMap a) t+instance Wrapped (IntMap a) where+ type Unwrapped (IntMap a) = [(Int, a)]+ _Wrapped' = iso IntMap.toAscList IntMap.fromList+ {-# INLINE _Wrapped' #-} -- | Use @'wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list.-instance Wrapped [Int] [Int] IntSet IntSet where- wrapped = iso IntSet.fromList IntSet.toAscList- {-# INLINE wrapped #-}+instance (t ~ IntSet) => Rewrapped IntSet t+instance Wrapped IntSet where+ type Unwrapped IntSet = [Int]+ _Wrapped' = iso IntSet.toAscList IntSet.fromList+ {-# INLINE _Wrapped' #-} -- | 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- {-# INLINE wrapped #-}+instance (t ~ Map k' a', Ord k) => Rewrapped (Map k a) t+instance Ord k => Wrapped (Map k a) where+ type Unwrapped (Map k a) = [(k, a)]+ _Wrapped' = iso Map.toAscList Map.fromList+ {-# INLINE _Wrapped' #-} -- | 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- {-# INLINE wrapped #-}+instance (t ~ Set a', Ord a) => Rewrapped (Set a) t+instance Ord a => Wrapped (Set a) where+ type Unwrapped (Set a) = [a]+ _Wrapped' = iso Set.toAscList Set.fromList+ {-# INLINE _Wrapped' #-} -instance Wrapped [a] [b] (Seq a) (Seq b) where- wrapped = iso Seq.fromList Foldable.toList- {-# INLINE wrapped #-}+instance (t ~ Seq a') => Rewrapped (Seq a) t+instance Wrapped (Seq a) where+ type Unwrapped (Seq a) = [a]+ _Wrapped' = iso Foldable.toList Seq.fromList+ {-# INLINE _Wrapped' #-} +-- * semigroups++instance (t ~ S.Min b) => Rewrapped (S.Min a) t+instance Wrapped (S.Min a) where+ type Unwrapped (S.Min a) = a+ _Wrapped' = iso S.getMin S.Min+ {-# INLINE _Wrapped' #-}++instance (t ~ S.Max b) => Rewrapped (S.Max a) t+instance Wrapped (S.Max a) where+ type Unwrapped (S.Max a) = a+ _Wrapped' = iso S.getMax S.Max+ {-# INLINE _Wrapped' #-}++instance (t ~ S.First b) => Rewrapped (S.First a) t+instance Wrapped (S.First a) where+ type Unwrapped (S.First a) = a+ _Wrapped' = iso S.getFirst S.First+ {-# INLINE _Wrapped' #-}++instance (t ~ S.Last b) => Rewrapped (S.Last a) t+instance Wrapped (S.Last a) where+ type Unwrapped (S.Last a) = a+ _Wrapped' = iso S.getLast S.Last+ {-# INLINE _Wrapped' #-}++instance (t ~ S.WrappedMonoid b) => Rewrapped (S.WrappedMonoid a) t+instance Wrapped (S.WrappedMonoid a) where+ type Unwrapped (S.WrappedMonoid a) = a+ _Wrapped' = iso S.unwrapMonoid S.WrapMonoid+ {-# INLINE _Wrapped' #-}++instance (t ~ S.Option b) => Rewrapped (S.Option a) t+instance Wrapped (S.Option a) where+ type Unwrapped (S.Option a) = Maybe a+ _Wrapped' = iso S.getOption S.Option+ {-# INLINE _Wrapped' #-}+ -- * contravariant -instance Wrapped (a -> Bool) (a' -> Bool) (Predicate a) (Predicate a') where- wrapped = iso Predicate getPredicate- {-# INLINE wrapped #-}+instance (t ~ Predicate b) => Rewrapped (Predicate a) t+instance Wrapped (Predicate a) where+ type Unwrapped (Predicate a) = a -> Bool+ _Wrapped' = iso getPredicate Predicate+ {-# INLINE _Wrapped' #-} -instance Wrapped (a -> a -> Ordering) (a' -> a' -> Ordering) (Comparison a) (Comparison a') where- wrapped = iso Comparison getComparison- {-# INLINE wrapped #-}+instance (t ~ Comparison b) => Rewrapped (Comparison a) t+instance Wrapped (Comparison a) where+ type Unwrapped (Comparison a) = a -> a -> Ordering+ _Wrapped' = iso getComparison Comparison+ {-# INLINE _Wrapped' #-} -instance Wrapped (a -> a -> Bool) (a' -> a' -> Bool) (Equivalence a) (Equivalence a') where- wrapped = iso Equivalence getEquivalence- {-# INLINE wrapped #-}+instance (t ~ Equivalence b) => Rewrapped (Equivalence a) t+instance Wrapped (Equivalence a) where+ type Unwrapped (Equivalence a) = a -> a -> Bool+ _Wrapped' = iso getEquivalence Equivalence+ {-# INLINE _Wrapped' #-} -instance Wrapped (b -> a) (b' -> a') (Op a b) (Op a' b') where- wrapped = iso Op getOp- {-# INLINE wrapped #-}+instance (t ~ Op a' b') => Rewrapped (Op a b) t+instance Wrapped (Op a b) where+ type Unwrapped (Op a b) = b -> a+ _Wrapped' = iso getOp Op+ {-# INLINE _Wrapped' #-} -instance Wrapped (f (g a)) (f' (g' a')) (Contravariant.Compose f g a) (Contravariant.Compose f' g' a') where- wrapped = iso Contravariant.Compose Contravariant.getCompose- {-# INLINE wrapped #-}+instance (t ~ Contravariant.Compose f' g' a') => Rewrapped (Contravariant.Compose f g a) t+instance Wrapped (Contravariant.Compose f g a) where+ type Unwrapped (Contravariant.Compose f g a) = f (g a)+ _Wrapped' = iso Contravariant.getCompose Contravariant.Compose+ {-# INLINE _Wrapped' #-} -instance Wrapped (f (g a)) (f' (g' a')) (Contravariant.ComposeFC f g a) (Contravariant.ComposeFC f' g' a') where- wrapped = iso Contravariant.ComposeFC Contravariant.getComposeFC- {-# INLINE wrapped #-}+instance (t ~ Contravariant.ComposeFC f' g' a') => Rewrapped (Contravariant.ComposeFC f g a) t+instance Wrapped (Contravariant.ComposeFC f g a) where+ type Unwrapped (Contravariant.ComposeFC f g a) = f (g a)+ _Wrapped' = iso Contravariant.getComposeFC Contravariant.ComposeFC+ {-# INLINE _Wrapped' #-} -instance Wrapped (f (g a)) (f' (g' a')) (Contravariant.ComposeCF f g a) (Contravariant.ComposeFC f' g' a') where- wrapped = iso Contravariant.ComposeCF Contravariant.getComposeFC- {-# INLINE wrapped #-}+instance (t ~ Contravariant.ComposeCF f' g' a') => Rewrapped (Contravariant.ComposeCF f g a) t+instance Wrapped (Contravariant.ComposeCF f g a) where+ type Unwrapped (Contravariant.ComposeCF f g a) = f (g a)+ _Wrapped' = iso Contravariant.getComposeCF Contravariant.ComposeCF+ {-# INLINE _Wrapped' #-} -- * tagged -instance Wrapped a b (Tagged s a) (Tagged t b) where- wrapped = iso Tagged unTagged- {-# INLINE wrapped #-}+instance (t ~ Tagged s' a') => Rewrapped (Tagged s a) t+instance Wrapped (Tagged s a) where+ type Unwrapped (Tagged s a) = a+ _Wrapped' = iso unTagged Tagged+ {-# INLINE _Wrapped' #-} -- * Control.Exception -instance Wrapped String String AssertionFailed AssertionFailed where- wrapped = iso AssertionFailed failedAssertion- {-# INLINE wrapped #-}+instance (t ~ AssertionFailed) => Rewrapped AssertionFailed t+instance Wrapped AssertionFailed where+ type Unwrapped AssertionFailed = String+ _Wrapped' = iso failedAssertion AssertionFailed+ {-# INLINE _Wrapped' #-} -instance Wrapped String String NoMethodError NoMethodError where- wrapped = iso NoMethodError getNoMethodError- {-# INLINE wrapped #-}+instance (t ~ NoMethodError) => Rewrapped NoMethodError t+instance Wrapped NoMethodError where+ type Unwrapped NoMethodError = String+ _Wrapped' = iso getNoMethodError NoMethodError+ {-# INLINE _Wrapped' #-} -instance Wrapped String String PatternMatchFail PatternMatchFail where- wrapped = iso PatternMatchFail getPatternMatchFail- {-# INLINE wrapped #-}+instance (t ~ PatternMatchFail) => Rewrapped PatternMatchFail t+instance Wrapped PatternMatchFail where+ type Unwrapped PatternMatchFail = String+ _Wrapped' = iso getPatternMatchFail PatternMatchFail+ {-# INLINE _Wrapped' #-} -instance Wrapped String String RecConError RecConError where- wrapped = iso RecConError getRecConError- {-# INLINE wrapped #-}+instance (t ~ RecConError) => Rewrapped RecConError t+instance Wrapped RecConError where+ type Unwrapped RecConError = String+ _Wrapped' = iso getRecConError RecConError+ {-# INLINE _Wrapped' #-} -instance Wrapped String String RecSelError RecSelError where- wrapped = iso RecSelError getRecSelError- {-# INLINE wrapped #-}+instance (t ~ RecSelError) => Rewrapped RecSelError t+instance Wrapped RecSelError where+ type Unwrapped RecSelError = String+ _Wrapped' = iso getRecSelError RecSelError+ {-# INLINE _Wrapped' #-} -instance Wrapped String String RecUpdError RecUpdError where- wrapped = iso RecUpdError getRecUpdError- {-# INLINE wrapped #-}+instance (t ~ RecUpdError) => Rewrapped RecUpdError t+instance Wrapped RecUpdError where+ type Unwrapped RecUpdError = String+ _Wrapped' = iso getRecUpdError RecUpdError+ {-# INLINE _Wrapped' #-} -instance Wrapped String String ErrorCall ErrorCall where- wrapped = iso ErrorCall getErrorCall- {-# INLINE wrapped #-}+instance (t ~ ErrorCall) => Rewrapped ErrorCall t+instance Wrapped ErrorCall where+ type Unwrapped ErrorCall = String+ _Wrapped' = iso getErrorCall ErrorCall+ {-# INLINE _Wrapped' #-} getErrorCall :: ErrorCall -> String getErrorCall (ErrorCall x) = x@@ -398,73 +568,41 @@ -- -- >>> op Const (Const "hello") -- "hello"-op :: Wrapped s s a a => (s -> a) -> a -> s-op f = review (wrapping f)+op :: Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s+op _ = view _Wrapped' {-# 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 #-}---- | A convenient type-restricted version of 'wrapped' for aiding type inference.-wrapped' :: Wrapped s s a a => Iso' s a-wrapped' = wrapped-{-# INLINE wrapped' #-}---- | A convenient type-restricted version of 'unwrapped' for aiding type inference.-unwrapped' :: Wrapped s s a a => Iso' a s-unwrapped' = unwrapped-{-# 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.+-- | This is a convenient version of '_Wrapped' with an argument that's ignored. -- -- 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 #-}+_Wrapping' :: Wrapped s => (Unwrapped s -> s) -> Iso' s (Unwrapped s)+_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.+-- | This is a convenient version of '_Wrapped' with an argument that's ignored. -- -- 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 #-}+_Unwrapping' :: Wrapped s => (Unwrapped s -> s) -> Iso' (Unwrapped s) s+_Unwrapping' _ = from _Wrapped'+{-# 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.+-- | This is a convenient version of '_Wrapped' with an argument that's ignored. ----- 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 #-}+-- The user supplied function is /ignored/, merely its types are used.+_Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)+_Wrapping _ = _Wrapped+{-# INLINE _Wrapping #-} --- | 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.+-- | This is a convenient version of '_Unwrapped' with an argument that's ignored. ----- 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 #-}+-- The user supplied function is /ignored/, merely its types are used.+_Unwrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso (Unwrapped t) (Unwrapped s) t s+_Unwrapping _ = from _Wrapped+{-# INLINE _Unwrapping #-} -- | 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/.+-- As with '_Wrapping', the user supplied function for the newtype is /ignored/. -- -- >>> ala Sum foldMap [1,2,3,4] -- 10@@ -486,16 +624,16 @@ -- -- >>> 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+ala :: Rewrapping s t => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> e -> s) -> e -> Unwrapped s+ala = au . _Unwrapping {-# 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/.+-- 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+alaf :: (Profunctor p, Rewrapping s t) => (Unwrapped s -> s) -> (p r t -> e -> s) -> p r (Unwrapped t) -> e -> Unwrapped s+alaf = auf . _Unwrapping {-# INLINE alaf #-}
− src/Control/Lens/Zipper.hs
@@ -1,95 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Control.Lens.Zipper--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable------ This module provides a 'Zipper' with fairly strong type checking guarantees.------ The code here is inspired by Brandon Simmons' @zippo@ package, but uses--- a different approach to represent the 'Zipper' that makes the whole thing--- look like his breadcrumb trail, and can move side-to-side through--- traversals.------ Some examples types:------ [@'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--- '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--- 'Control.Lens.Type.IndexedTraversal', you can move left and right through--- the 'Control.Lens.Type.IndexedTraversal' selecting neighboring elements.------ >>> 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',--- 'Data.Data.Lens.uniplate' or 'Data.Data.Lens.biplate' for walking down into--- self-similar children in syntax trees and other structures.------ Given keys in ascending order you can jump directly to a given key with--- 'moveTo'. When used with traversals for balanced--- tree-like structures such as an 'Data.IntMap.IntMap' or 'Data.Map.Map',--- searching for a key with 'moveTo' can be done in logarithmic time.-------------------------------------------------------------------------------module Control.Lens.Zipper- (- -- * Zippers- Top()- , (:>)()- , (:>>)()- , (:@)()- , Zipper- , zipper- -- ** Focusing- , focus- , focusedContext- -- ** Vertical Movement- , upward- , downward, idownward- , within, iwithin- , withins, iwithins- -- ** Lateral Movement- , leftward, rightward- , leftmost, rightmost- -- ** Movement Combinators- , tug- , tugs- , jerks- , farthest- -- ** Absolute Positioning- , tooth- , teeth- , jerkTo- , tugTo- , moveTo- , moveToward- -- ** Closing the zipper- , rezip- , Zipped- , Zipping()- -- ** Recording- , Tape()- , saveTape- , restoreTape- , restoreNearTape- -- ** Unsafe Movement- , fromWithin- , ifromWithin- , unsafelyRestoreTape- ) where--import Control.Lens.Internal.Zipper---- $setup--- >>> :set -XNoOverloadedStrings--- >>> import Control.Lens
src/Control/Lens/Zoom.hs view
@@ -11,7 +11,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Zoom--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Control/Monad/Error/Lens.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Error.Lens--- Copyright : (C) 2013 Edward Kmett+-- Copyright : (C) 2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -108,7 +108,7 @@ -- Trying ------------------------------------------------------------------------------ --- | 'trying' takes a 'Prism' (or any 'Getter') to select which exceptions are caught +-- | 'trying' takes a 'Prism' (or any 'Getter') to select which exceptions are caught -- If the 'Exception' does not match the predicate, it is re-thrown. -- -- @@@ -221,4 +221,3 @@ Nothing -> throwError e Just x -> k x {-# INLINE catchJust #-}-
+ src/Control/Monad/Primitive/Lens.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Primitive.Lens+-- Copyright : (C) 2014 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : Control.Monad.Primitive+--+----------------------------------------------------------------------------+module Control.Monad.Primitive.Lens+ (+ prim+ ) where++import Control.Lens+import Control.Monad.Primitive (PrimMonad(..))+import GHC.Prim (State#)++{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}++prim :: (PrimMonad m) => Iso' (m a) (State# (PrimState m) -> (# State# (PrimState m), a #))+prim = iso internal primitive+{-# INLINE prim #-}
src/Control/Parallel/Strategies/Lens.hs view
@@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Parallel.Strategies.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Control/Seq/Lens.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Seq.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
+ src/Data/Aeson/Lens.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DefaultSignatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+--------------------------------------------------------------------+-- |+-- Copyright : (c) Edward Kmett 2013-2014, (c) Paul Wilson 2012+-- License : BSD3+-- Maintainer: Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability: non-portable+--+--------------------------------------------------------------------+module Data.Aeson.Lens+ (+ -- * Numbers+ AsNumber(..)+ , _Integral+ , nonNull+ -- * Primitive+ , Primitive(..)+ , AsPrimitive(..)+ -- * Objects and Arrays+ , AsValue(..)+ , key, members+ , nth, values+ -- * Decoding+ , AsJSON(..)+ ) where++import Control.Applicative+import Control.Lens+import Data.Aeson+import Data.Scientific+import Data.ByteString.Lazy.Char8 as Lazy hiding (putStrLn)+import Data.ByteString.Lazy.UTF8 as UTF8 hiding (decode)+import Data.Data+import Data.HashMap.Strict (HashMap)+import Data.Text+import Data.Vector (Vector)+import Prelude hiding (null)++-- $setup+-- >>> :set -XOverloadedStrings++------------------------------------------------------------------------------+-- Scientific prisms+------------------------------------------------------------------------------++class AsNumber t where+ -- |+ -- >>> "[1, \"x\"]" ^? nth 0 . _Number+ -- Just 1.0+ --+ -- >>> "[1, \"x\"]" ^? nth 1 . _Number+ -- Nothing+ _Number :: Prism' t Scientific+#ifndef HLINT+ default _Number :: AsPrimitive t => Prism' t Scientific+ _Number = _Primitive._Number+ {-# INLINE _Number #-}+#endif++ -- |+ -- Prism into an 'Double' over a 'Value', 'Primitive' or 'Scientific'+ --+ -- >>> "[10.2]" ^? nth 0 . _Double+ -- Just 10.2+ _Double :: Prism' t Double+ _Double = _Number.iso realToFrac realToFrac+ {-# INLINE _Double #-}++ -- |+ -- Prism into an 'Integer' over a 'Value', 'Primitive' or 'Scientific'+ --+ -- >>> "[10]" ^? nth 0 . _Integer+ -- Just 10+ --+ -- >>> "[10.5]" ^? nth 0 . _Integer+ -- Just 10+ _Integer :: Prism' t Integer+ _Integer = _Number.iso floor fromIntegral+ {-# INLINE _Integer #-}++instance AsNumber Value where+ _Number = prism Number $ \v -> case v of Number n -> Right n; _ -> Left v+ {-# INLINE _Number #-}++instance AsNumber Scientific where+ _Number = id+ {-# INLINE _Number #-}++instance AsNumber ByteString+instance AsNumber String++------------------------------------------------------------------------------+-- Conversion Prisms+------------------------------------------------------------------------------++-- | Access Integer 'Value's as Integrals.+--+-- >>> "[10]" ^? nth 0 . _Integral+-- Just 10+--+-- >>> "[10.5]" ^? nth 0 . _Integral+-- Just 10+_Integral :: (AsNumber t, Integral a) => Prism' t a+_Integral = _Number . iso floor fromIntegral+{-# INLINE _Integral #-}++------------------------------------------------------------------------------+-- Null values and primitives+------------------------------------------------------------------------------++-- | Primitives of 'Value'+data Primitive+ = StringPrim !Text+ | NumberPrim !Scientific+ | BoolPrim !Bool+ | NullPrim+ deriving (Eq,Ord,Show,Data,Typeable)++instance AsNumber Primitive where+ _Number = prism NumberPrim $ \v -> case v of NumberPrim s -> Right s; _ -> Left v+ {-# INLINE _Number #-}++class AsNumber t => AsPrimitive t where+ -- |+ -- >>> "[1, \"x\", null, true, false]" ^? nth 0 . _Primitive+ -- Just (NumberPrim 1.0)+ --+ -- >>> "[1, \"x\", null, true, false]" ^? nth 1 . _Primitive+ -- Just (StringPrim "x")+ --+ -- >>> "[1, \"x\", null, true, false]" ^? nth 2 . _Primitive+ -- Just NullPrim+ --+ -- >>> "[1, \"x\", null, true, false]" ^? nth 3 . _Primitive+ -- Just (BoolPrim True)+ --+ -- >>> "[1, \"x\", null, true, false]" ^? nth 4 . _Primitive+ -- Just (BoolPrim False)+ _Primitive :: Prism' t Primitive+#ifndef HLINT+ default _Primitive :: AsValue t => Prism' t Primitive+ _Primitive = _Value._Primitive+ {-# INLINE _Primitive #-}+#endif++ -- "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _String+ -- Just "xyz"+ --+ -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _String+ -- Nothing+ _String :: Prism' t Text+ _String = _Primitive.prism StringPrim (\v -> case v of StringPrim s -> Right s; _ -> Left v)+ {-# INLINE _String #-}++ -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _Bool+ -- Just True+ --+ -- "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _Bool+ -- Nothing+ _Bool :: Prism' t Bool+ _Bool = _Primitive.prism BoolPrim (\v -> case v of BoolPrim b -> Right b; _ -> Left v)+ {-# INLINE _Bool #-}++ -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . _Null+ -- Just ()+ --+ -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . _Null+ -- Nothing+ _Null :: Prism' t ()+ _Null = _Primitive.prism (const NullPrim) (\v -> case v of NullPrim -> Right (); _ -> Left v)+ {-# INLINE _Null #-}+++instance AsPrimitive Value where+ _Primitive = prism fromPrim toPrim+ where+ toPrim (String s) = Right $ StringPrim s+ toPrim (Number n) = Right $ NumberPrim n+ toPrim (Bool b) = Right $ BoolPrim b+ toPrim Null = Right NullPrim+ toPrim v = Left v+ {-# INLINE toPrim #-}+ fromPrim (StringPrim s) = String s+ fromPrim (NumberPrim n) = Number n+ fromPrim (BoolPrim b) = Bool b+ fromPrim NullPrim = Null+ {-# INLINE fromPrim #-}+ {-# INLINE _Primitive #-}+ _String = prism String $ \v -> case v of String s -> Right s; _ -> Left v+ {-# INLINE _String #-}+ _Bool = prism Bool (\v -> case v of Bool b -> Right b; _ -> Left v)+ {-# INLINE _Bool #-}+ _Null = prism (const Null) (\v -> case v of Null -> Right (); _ -> Left v)+ {-# INLINE _Null #-}++instance AsPrimitive ByteString+instance AsPrimitive String++instance AsPrimitive Primitive where+ _Primitive = id+ {-# INLINE _Primitive #-}++-- | Prism into non-'Null' values+--+-- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . nonNull+-- Just (String "xyz")+--+-- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . nonNull+-- Just (Object fromList [])+--+-- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . nonNull+-- Nothing+nonNull :: Prism' Value Value+nonNull = prism id (\v -> if isn't _Null v then Right v else Left v)+{-# INLINE nonNull #-}++------------------------------------------------------------------------------+-- Non-primitive traversals+------------------------------------------------------------------------------++class AsPrimitive t => AsValue t where+ -- |+ -- >>> "[1,2,3]" ^? _Value+ -- Just (Array (fromList [Number 1.0,Number 2.0,Number 3.0]))+ _Value :: Prism' t Value++ -- |+ -- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . _Object+ -- Just fromList []+ --+ -- >>> "{\"a\": {}, \"b\": null}" ^? key "b" . _Object+ -- Nothing+ _Object :: Prism' t (HashMap Text Value)+ _Object = _Value.prism Object (\v -> case v of Object o -> Right o; _ -> Left v)+ {-# INLINE _Object #-}++ -- |+ -- >>> "[1,2,3]" ^? _Array+ -- Just (fromList [Number 1.0,Number 2.0,Number 3.0])+ _Array :: Prism' t (Vector Value)+ _Array = _Value.prism Array (\v -> case v of Array a -> Right a; _ -> Left v)+ {-# INLINE _Array #-}++instance AsValue Value where+ _Value = id+ {-# INLINE _Value #-}++instance AsValue ByteString where+ _Value = _JSON+ {-# INLINE _Value #-}++instance AsValue String where+ _Value = iso UTF8.fromString UTF8.toString._Value+ {-# INLINE _Value #-}++-- |+-- Like 'ix', but for 'Object' with Text indices. This often has better+-- inference than 'ix' when used with OverloadedStrings.+--+-- >>> "{\"a\": 100, \"b\": 200}" ^? key "a"+-- Just (Number 100.0)+--+-- >>> "[1,2,3]" ^? key "a"+-- Nothing+key :: AsValue t => Text -> Traversal' t Value+key i = _Object . ix i+{-# INLINE key #-}++-- | An indexed Traversal into Object properties+--+-- >>> "{\"a\": 4, \"b\": 7}" ^@.. members+-- [("a",Number 4.0),("b",Number 7.0)]+--+-- >>> "{\"a\": 4, \"b\": 7}" & members . _Number *~ 10+-- "{\"a\":40,\"b\":70}"+members :: AsValue t => IndexedTraversal' Text t Value+members = _Object . itraversed+{-# INLINE members #-}++-- | Like 'ix', but for Arrays with Int indexes+--+-- >>> "[1,2,3]" ^? nth 1+-- Just (Number 2.0)+--+-- >>> "\"a\": 100, \"b\": 200}" ^? nth 1+-- Nothing+--+-- >>> "[1,2,3]" & nth 1 .~ Number 20+-- "[1,20,3]"+nth :: AsValue t => Int -> Traversal' t Value+nth i = _Array . ix i+{-# INLINE nth #-}++-- | An indexed Traversal into Array elements+--+-- >>> "[1,2,3]" ^.. values+-- [Number 1.0,Number 2.0,Number 3.0]+--+-- >>> "[1,2,3]" & values . _Number *~ 10+-- "[10,20,30]"+values :: AsValue t => IndexedTraversal' Int t Value+values = _Array . traversed+{-# INLINE values #-}++class AsJSON t where+ -- | A Prism into 'Value' on lazy 'ByteString's.+ _JSON :: (FromJSON a, ToJSON a) => Prism' t a++instance AsJSON Lazy.ByteString where+ _JSON = prism' encode decode+ {-# INLINE _JSON #-}++instance AsJSON String where+ _JSON = iso UTF8.fromString UTF8.toString._JSON+ {-# INLINE _JSON #-}++instance AsJSON Value where+ _JSON = prism toJSON $ \x -> case fromJSON x of+ Success y -> Right y;+ _ -> Left x+ {-# INLINE _JSON #-}++------------------------------------------------------------------------------+-- Orphan instances+------------------------------------------------------------------------------++type instance Index Value = Text+type instance IxValue Value = Value++instance Ixed Value where+ ix i = _Object.ix i+ {-# INLINE ix #-}++instance Plated Value where+ plate f (Object o) = Object <$> traverse f o+ plate f (Array a) = Array <$> traverse f a+ plate _ xs = pure xs+ {-# INLINE plate #-}
src/Data/Array/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/Bits/Lens.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Bits.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -11,8 +11,8 @@ -- ---------------------------------------------------------------------------- module Data.Bits.Lens- ( (.|.~), (.&.~), (<.|.~), (<.&.~)- , (.|.=), (.&.=), (<.|.=), (<.&.=)+ ( (.|.~), (.&.~), (<.|.~), (<.&.~), (<<.|.~), (<<.&.~)+ , (.|.=), (.&.=), (<.|.=), (<.&.=), (<<.|.=), (<<.&.=) , bitAt , bits , byteAt@@ -28,8 +28,8 @@ -- >>> :set -XNoOverloadedStrings -- >>> import Data.Word -infixr 4 .|.~, .&.~, <.|.~, <.&.~-infix 4 .|.=, .&.=, <.|.=, <.&.=+infixr 4 .|.~, .&.~, <.|.~, <.&.~, <<.|.~, <<.&.~+infix 4 .|.=, .&.=, <.|.=, <.&.=, <<.|.=, <<.&.= -- | Bitwise '.|.' the target(s) of a 'Lens' or 'Setter'. --@@ -148,6 +148,22 @@ (<.|.=) :: (MonadState s m, Bits a) => LensLike' ((,)a) s a -> a -> m a l <.|.= b = l <%= (.|. b) {-# INLINE (<.|.=) #-}++(<<.&.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s)+l <<.&.~ b = l $ \a -> (a, a .&. b)+{-# INLINE (<<.&.~) #-}++(<<.|.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s)+l <<.|.~ b = l $ \a -> (a, a .|. b)+{-# INLINE (<<.|.~) #-}++(<<.&.=) :: (MonadState s m, Bits a) => LensLike' ((,) a) s a -> a -> m a+l <<.&.= b = l %%= \a -> (a, a .&. b)+{-# INLINE (<<.&.=) #-}++(<<.|.=) :: (MonadState s m, Bits a) => LensLike' ((,) a) s a -> a -> m a+l <<.|.= b = l %%= \a -> (a, a .|. b)+{-# INLINE (<<.|.=) #-} -- | This 'Lens' can be used to access the value of the nth bit in a number. --
src/Data/ByteString/Lazy/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lazy.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/ByteString/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/ByteString/Strict/Lens.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/Complex/Lens.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Complex.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/Data/Lens.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-}+#ifndef HLINT {-# LANGUAGE UnboxedTuples #-}+#endif {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif@@ -14,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Data.Lens--- Copyright : (C) 2012-2013 Edward Kmett, (C) 2006-2012 Neil Mitchell+-- Copyright : (C) 2012-2014 Edward Kmett, (C) 2006-2012 Neil Mitchell -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -44,18 +47,15 @@ import Control.Applicative import Control.Exception as E-import Control.Lens.Combinators import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed+import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type import Data.Data import GHC.IO-import Unsafe.Coerce as Unsafe import Data.Maybe--#ifndef SAFE import Data.Foldable import qualified Data.HashMap.Strict as M import Data.HashMap.Strict (HashMap, (!))@@ -64,12 +64,12 @@ import Data.IORef import Data.Monoid import GHC.Exts (realWorld#)-#endif #ifdef HLINT {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Use foldl" #-} {-# ANN module "HLint: ignore Reduce duplication" #-}+{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} #endif -- $setup@@ -100,10 +100,10 @@ tinplate f = gfoldl (step f) pure {-# INLINE tinplate #-} -step :: (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r-step f w s = w <*> case cast s of- Just a -> unsafeCoerce <$> f a- Nothing -> tinplate f s+step :: forall s a f r. (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r+step f w s = w <*> case mightBe :: Maybe (Is s a) of+ Just Data.Data.Lens.Refl -> f s+ Nothing -> tinplate f s {-# INLINE step #-} -------------------------------------------------------------------------------@@ -116,12 +116,8 @@ -- -- This is 'uniplate' with a more liberal signature. template :: forall s a. (Data s, Typeable a) => 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@@ -134,14 +130,8 @@ -- | 'biplate' performs like 'template', except when @s ~ a@, it returns itself and nothing else. biplate :: forall s a. (Data s, Typeable a) => 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 #-} ------------------------------------------------------------------------------@@ -156,7 +146,7 @@ instance Typeable a => Exception (FieldException a) -lookupon :: Typeable a => LensLike' (Indexing Mutator) s a -> (s -> a) -> s -> Maybe (Int, Context a a s)+lookupon :: Typeable a => LensLike' (Indexing Identity) s a -> (s -> a) -> s -> Maybe (Int, Context a a s) 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@@ -271,8 +261,17 @@ ~(i, Context k _) = fromMaybe (error "upon': no index, not a member") (lookupon template field s) {-# INLINE onceUpon' #-} -#ifndef SAFE+-------------------------------------------------------------------------------+-- Type equality+------------------------------------------------------------------------------- +data Is a b where+ Refl :: Is a a++mightBe :: (Typeable a, Typeable b) => Maybe (Is a b)+mightBe = gcast Data.Data.Lens.Refl+{-# INLINE mightBe #-}+ ------------------------------------------------------------------------------- -- Data Box -------------------------------------------------------------------------------@@ -323,7 +322,7 @@ trans :: HitMap -> HitMap trans m = M.map f m where f x = x `mappend` foldMap g x- g x = M.lookupDefault (hit ! x) x m+ g x = fromMaybe (hit ! x) (M.lookup x m) fixEq :: Eq a => (a -> a) -> a -> a fixEq f = go where@@ -376,63 +375,49 @@ -- Answers ------------------------------------------------------------------------------- -data Answer a- = Hit a+data Answer b a+ = b ~ a => Hit a | Follow | Miss- deriving (Eq,Ord,Show,Read) -instance Functor Answer where- fmap f (Hit a) = Hit (f a)- fmap _ Follow = Follow- fmap _ Miss = Miss- {-# INLINE fmap #-}- ------------------------------------------------------------------------------- -- Oracles ------------------------------------------------------------------------------- -newtype Oracle a = Oracle { fromOracle :: forall t. Typeable t => t -> Answer a }--instance Functor Oracle where- fmap f (Oracle g) = Oracle (fmap f . g)- {-# INLINE fmap #-}+newtype Oracle a = Oracle { fromOracle :: forall t. Typeable t => t -> Answer t a } -hitTest :: (Data a, Typeable b) => a -> b -> Oracle b-hitTest a b- | kb <- typeOf b = case readCacheFollower (dataBox a) kb of- Nothing -> Oracle $ \c ->- if typeOf c == kb- then Hit (unsafeCoerce c)- else Follow- Just p -> Oracle $ \c -> let kc = typeOf c in- if kc == kb then Hit (unsafeCoerce c)- else if p kc then Follow- else Miss+hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b+hitTest a b = Oracle $ \(c :: c) ->+ case mightBe :: Maybe (Is c b) of+ Just Data.Data.Lens.Refl -> Hit c+ Nothing ->+ case readCacheFollower (dataBox a) (typeOf b) of+ Just p | not (p (typeOf c)) -> Miss+ _ -> Follow ------------------------------------------------------------------------------- -- Traversals ------------------------------------------------------------------------------- -biplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer a) -> (a -> f a) -> s -> f s+biplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s biplateData o f a0 = go2 a0 where go :: Data d => d -> f d go s = gfoldl (\x y -> x <*> go2 y) pure s go2 :: Data d => d -> f d go2 s = case o s of- Hit a -> Unsafe.unsafeCoerce <$> f a+ Hit a -> f a Follow -> go s Miss -> pure s {-# INLINE biplateData #-} -uniplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer a) -> (a -> f a) -> s -> f s+uniplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s uniplateData o f a0 = go a0 where go :: Data d => d -> f d go s = gfoldl (\x y -> x <*> go2 y) pure s go2 :: Data d => d -> f d go2 s = case o s of- Hit a -> Unsafe.unsafeCoerce <$> f a+ Hit a -> f a Follow -> go s Miss -> pure s {-# INLINE uniplateData #-}@@ -454,5 +439,3 @@ | S.size hit < S.size miss = S.member ?? hit | 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
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/HashSet/Lens.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.HashSet.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/IntSet/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntSet.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/List/Lens.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/List/Split/Lens.hs view
@@ -2,7 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module : Data.List.Split.Lens--- Copyright : (C) 2012-2013 Edward Kmett, Alexander Altman+-- Copyright : (C) 2012-2014 Edward Kmett, Alexander Altman -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -39,7 +39,10 @@ import Data.List.Split.Internals -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Numeric.Lens (hex)+-- >>> import Data.Char (chr) -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' according to the given splitting strategy. --@@ -128,6 +131,9 @@ {-# INLINE liningBy #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into length-@n@ pieces.+--+-- >>> "48656c6c6f20776f726c64"^..chunking 2 folded.hex.to chr+-- "Hello world" -- -- @ -- 'chunking' :: 'Int' -> 'Fold' s a -> 'Fold' s [a]
+ src/Data/Map/Lens.hs view
@@ -0,0 +1,57 @@+-- | One of most commonly-asked questions about this package is whether+-- it provides lenses for working with 'Data.Map.Map'. It does, but their uses+-- are perhaps obscured by their genericity. This module exists to provide+-- documentation for them.+--+-- 'Data.Map.Map' is an instance of 'Control.Lens.At.At', so we have a lenses+-- on values at keys:+--+-- >>> Map.fromList [(1, "world")] ^.at 1+-- Just "world"+--+-- >>> at 1 .~ Just "world" $ Map.empty+-- fromList [(1,"world")]+--+-- >>> at 0 ?~ "hello" $ Map.empty+-- fromList [(0,"hello")]+--+-- We can traverse, fold over, and map over key-value pairs in a+-- 'Data.Map.Map', thanks to its 'Control.Lens.Indexed.TraversableWithIndex',+-- 'Control.Lens.Indexed.FoldableWithIndex', and+-- 'Control.Lens.Indexed.FunctorWithIndex' instances.+--+-- >>> imap const $ Map.fromList [(1, "Venus")]+-- fromList [(1,1)]+--+-- >>> ifoldMap (\i _ -> Sum i) $ Map.fromList [(2, "Earth"), (3, "Mars")]+-- Sum {getSum = 5}+--+-- >>> itraverse_ (curry print) $ Map.fromList [(4, "Jupiter")]+-- (4,"Jupiter")+--+-- >>> itoList $ Map.fromList [(5, "Saturn")]+-- [(5,"Saturn")]+--+-- A related class, 'Control.Lens.At.Ixed', allows us to use+-- 'Control.Lens.At.ix' to traverse a value at a particular key.+--+-- >>> ix 2 %~ ("New " ++) $ Map.fromList [(2, "Earth")]+-- fromList [(2,"New Earth")]+--+-- >>> preview (ix 8) $ Map.empty+-- Nothing+--+-- Additionally, 'Data.Map.Map' has 'Control.Lens.Traversal.TraverseMin' and+-- 'Control.Lens.Traversal.TraverseMax' instances, which let us traverse over+-- the value at the least and greatest keys, respectively.+--+-- >>> preview traverseMin $ Map.fromList [(5, "Saturn"), (6, "Uranus")]+-- Just "Saturn"+--+-- >>> preview traverseMax $ Map.fromList [(5, "Saturn"), (6, "Uranus")]+-- Just "Uranus"+module Data.Map.Lens () where+-- $setup+-- >>> import Control.Lens+-- >>> import Data.Monoid+-- >>> import qualified Data.Map as Map
src/Data/Sequence/Lens.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Sequence.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -13,6 +13,7 @@ module Data.Sequence.Lens ( viewL, viewR , sliced, slicedTo, slicedFrom+ , seqOf ) where import Control.Applicative@@ -115,3 +116,22 @@ (l,mr) -> case Seq.splitAt (j-i) mr of (m, r) -> itraverse (indexed f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-}++-- | Construct a 'Seq' from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'.+--+-- >>> seqOf folded ["hello","world"]+-- fromList ["hello","world"]+--+-- >>> seqOf (folded._2) [("hello",1),("world",2),("!!!",3)]+-- fromList [1,2,3]+--+-- @+-- 'seqOf' :: 'Getter' s a -> s -> 'Seq' a+-- 'seqOf' :: 'Fold' s a -> s -> 'Seq' a+-- 'seqOf' :: 'Iso'' s a -> s -> 'Seq' a+-- 'seqOf' :: 'Lens'' s a -> s -> 'Seq' a+-- 'seqOf' :: 'Traversal'' s a -> s -> 'Seq' a+-- @+seqOf :: Getting (Seq a) s a -> s -> Seq a+seqOf l = views l Seq.singleton+{-# INLINE seqOf #-}
src/Data/Set/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/Text/Lazy/Lens.hs view
@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lazy.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -18,11 +18,14 @@ ( packed, unpacked , text , builder+ , utf8 ) where import Control.Lens+import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy import Data.Text.Lazy.Builder+import Data.Text.Lazy.Encoding -- $setup -- >>> :set -XOverloadedStrings@@ -87,3 +90,14 @@ text :: IndexedTraversal' Int Text Char text = unpacked . traversed {-# INLINE text #-}++-- | Encode/Decode a lazy 'Text' to/from lazy 'ByteString', via UTF-8.+--+-- Note: This function does not decode lazily, as it must consume the entire+-- input before deciding whether or not it fails.+--+-- >>> utf8 # "☃"+-- "\226\152\131"+utf8 :: Prism' ByteString Text+utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8')+{-# INLINE utf8 #-}
src/Data/Text/Lens.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/Text/Strict/Lens.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Strict.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -17,10 +17,13 @@ ( packed, unpacked , builder , text+ , utf8 ) where import Control.Lens+import Data.ByteString (ByteString) import Data.Text+import Data.Text.Encoding import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder @@ -86,3 +89,11 @@ text :: IndexedTraversal' Int Text Char text = unpacked . traversed {-# INLINE text #-}++-- | Encode/Decode a strict 'Text' to/from strict 'ByteString', via UTF-8.+--+-- >>> utf8 # "☃"+-- "\226\152\131"+utf8 :: Prism' ByteString Text+utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8')+{-# INLINE utf8 #-}
src/Data/Tree/Lens.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/Typeable/Lens.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Typeable.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Data/Vector/Generic/Lens.hs view
@@ -7,7 +7,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Generic.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/Data/Vector/Lens.hs view
@@ -8,7 +8,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
src/GHC/Generics/Lens.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental
src/Generics/Deriving/Lens.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Generics.Deriving.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -13,15 +13,13 @@ -- -- Note: @Generics.Deriving@ exports a number of names that collide with @Control.Lens@. ----- You can use hiding or imports to mitigate this to an extent, and the following imports,--- represent a fair compromise for user code:+-- You can use hiding to mitigate this to an extent, and the following import+-- represents a fair compromise for user code: ----- > import Control.Lens hiding (Rep) -- > import Generics.Deriving hiding (from, to) ----- You can use 'generic' to replace 'Generics.Deriving.from' and 'Generics.Deriving.to' from @Generics.Deriving@,--- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@--- in code that uses generics.+-- You can use 'generic' to replace 'Generics.Deriving.from' and+-- 'Generics.Deriving.to' from @Generics.Deriving@. ---------------------------------------------------------------------------- module Generics.Deriving.Lens (@@ -37,8 +35,8 @@ import Control.Lens import Data.Maybe (fromJust) import Data.Typeable-import qualified Generics.Deriving as Generic-import Generics.Deriving hiding (from, to)+import qualified GHC.Generics as Generic+import GHC.Generics hiding (from, to) -- $setup -- >>> :set -XNoOverloadedStrings
src/Language/Haskell/TH/Lens.hs view
@@ -6,135 +6,1794 @@ ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Lens--- Copyright : (C) 2012-2013 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : TemplateHaskell------ Lenses and Traversals for working with Template Haskell------------------------------------------------------------------------------module Language.Haskell.TH.Lens- ( HasName(..)- , HasTypeVars(..)- , SubstType(..)- , typeVars -- :: HasTypeVars t => Traversal' t Name- , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t- , conFields- , conNamedFields- ) where--import Control.Applicative-import Control.Lens.At-import Control.Lens.Getter-import Control.Lens.Setter-import Control.Lens.Fold-import Control.Lens.Lens-import Control.Lens.Tuple-import Control.Lens.Traversal-import Data.Map as Map hiding (toList,map)-import Data.Maybe (fromMaybe)-import Data.Monoid-import Data.Set as Set hiding (toList,map)-import Data.Set.Lens-import Language.Haskell.TH-import Language.Haskell.TH.Syntax---- | Has a 'Name'-class HasName t where- -- | Extract (or modify) the 'Name' of something- name :: Lens' t Name--instance HasName TyVarBndr where- name f (PlainTV n) = PlainTV <$> f n- name f (KindedTV n k) = (`KindedTV` k) <$> f n--instance HasName Name where- name = id--instance HasName Con where- name f (NormalC n tys) = (`NormalC` tys) <$> f n- name f (RecC n tys) = (`RecC` tys) <$> f n- name f (InfixC l n r) = (\n' -> InfixC l n' r) <$> f n- name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con---- | Provides for the extraction of free type variables, and alpha renaming.-class HasTypeVars t where- -- | When performing substitution into this traversal you're not allowed- -- to substitute in a name that is bound internally or you'll violate- -- the 'Traversal' laws, when in doubt generate your names with 'newName'.- typeVarsEx :: Set Name -> Traversal' t Name--instance HasTypeVars TyVarBndr where- typeVarsEx s f b- | s^.contains (b^.name) = pure b- | otherwise = name f b--instance HasTypeVars Name where- typeVarsEx s f n- | s^.contains n = pure n- | otherwise = f n--instance HasTypeVars Type where- typeVarsEx s f (VarT n) = VarT <$> typeVarsEx s f n- typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r- typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t- typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty- where s' = s `Set.union` setOf typeVars bs- typeVarsEx _ _ t = pure t--instance HasTypeVars Pred where- typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts- typeVarsEx s f (EqualP l r) = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r--instance HasTypeVars Con where- typeVarsEx s f (NormalC n ts) = NormalC n <$> traverseOf (traverse . _2) (typeVarsEx s f) ts- typeVarsEx s f (RecC n ts) = RecC n <$> traverseOf (traverse . _3) (typeVarsEx s f) ts- typeVarsEx s f (InfixC l n r) = InfixC <$> g l <*> pure n <*> g r- where g (i, t) = (,) i <$> typeVarsEx s f t- typeVarsEx s f (ForallC bs ctx c) = ForallC bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f c- where s' = s `Set.union` setOf typeVars bs--instance HasTypeVars t => HasTypeVars [t] where- typeVarsEx s = traverse . typeVarsEx s---- | Traverse /free/ type variables-typeVars :: HasTypeVars t => Traversal' t Name-typeVars = typeVarsEx mempty---- | Substitute using a map of names in for /free/ type variables-substTypeVars :: HasTypeVars t => Map Name Name -> t -> t-substTypeVars m = over typeVars $ \n -> fromMaybe n (m^.at n)---- | Provides substitution for types-class SubstType t where- -- | Perform substitution for types- substType :: Map Name Type -> t -> t--instance SubstType Type where- substType m t@(VarT n) = fromMaybe t (m^.at n)- substType m (ForallT bs ctx ty) = ForallT bs (substType m' ctx) (substType m' ty)- where m' = foldrOf typeVars Map.delete m bs- substType m (SigT t k) = SigT (substType m t) k- substType m (AppT l r) = AppT (substType m l) (substType m r)- substType _ t = t--instance SubstType t => SubstType [t] where- substType = map . substType--instance SubstType Pred where- substType m (ClassP n ts) = ClassP n (substType m ts)- substType m (EqualP l r) = substType m (EqualP l r)---- | Provides a 'Traversal' of the types of each field of a constructor.-conFields :: Traversal' Con StrictType-conFields f (NormalC n fs) = NormalC n <$> traverse f fs-conFields f (RecC n fs) = RecC n <$> traverse sans_var fs- where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t)-conFields f (InfixC l n r) = InfixC <$> f l <*> pure n <*> f r-conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c---- | 'Traversal' of the types of the /named/ fields of a constructor.-conNamedFields :: Traversal' Con VarStrictType-conNamedFields f (RecC n fs) = RecC n <$> traverse f fs-conNamedFields _ c = pure c+-- Copyright : (C) 2012-2014 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : TemplateHaskell+--+-- Lenses, Prisms, and Traversals for working with Template Haskell+----------------------------------------------------------------------------+module Language.Haskell.TH.Lens+ (+ -- * Traversals+ HasName(..)+ , HasTypeVars(..)+ , SubstType(..)+ , typeVars -- :: HasTypeVars t => Traversal' t Name+ , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t+ , conFields+ , conNamedFields+ -- * Lenses+ -- ** Loc Lenses+ , locFileName+ , locPackage+ , locModule+ , locStart+ , locEnd+ -- ** FunDep Lenses+ , funDepInputs+ , funDepOutputs+ -- ** Match Lenses+ , matchPattern+ , matchBody+ , matchDeclarations+ -- ** Fixity Lenses+ , fixityPrecedence+ , fixityDirection+ -- ** Clause Lenses+ , clausePattern+ , clauseBody+ , clauseDecs+ -- ** FieldExp Lenses+ , fieldExpName+ , fieldExpExpression+ -- ** FieldPat Lenses+ , fieldPatName+ , fieldPatPattern+#if MIN_VERSION_template_haskell(2,9,0)+ -- ** TySynEqn Lenses+ , tySynEqnPatterns+ , tySynEqnResult+#endif+ -- * Prisms+ -- ** Info Prisms+ , _ClassI+ , _ClassOpI+ , _TyConI+ , _FamilyI+ , _PrimTyConI+ , _DataConI+ , _VarI+ , _TyVarI+ -- ** Dec Prisms+ , _FunD+ , _ValD+ , _DataD+ , _NewtypeD+ , _TySynD+ , _ClassD+ , _InstanceD+ , _SigD+ , _ForeignD+#if MIN_VERSION_template_haskell(2,8,0)+ , _InfixD+#endif+ , _PragmaD+ , _FamilyD+ , _DataInstD+ , _NewtypeInstD+ , _TySynInstD+#if MIN_VERSION_template_haskell(2,9,0)+ , _ClosedTypeFamilyD+ , _RoleAnnotD+#endif+ -- ** Con Prisms+ , _NormalC+ , _RecC+ , _InfixC+ , _ForallC+ -- ** Strict Prisms+ , _IsStrict+ , _NotStrict+ , _Unpacked+ -- ** Foreign Prisms+ , _ImportF+ , _ExportF+ -- ** Callconv Prisms+ , _CCall+ , _StdCall+ -- ** Safety Prisms+ , _Unsafe+ , _Safe+ , _Interruptible+ -- ** Pragma Prisms+ , _InlineP+ , _SpecialiseP+#if MIN_VERSION_template_haskell(2,8,0)+ , _SpecialiseInstP+ , _RuleP+#if MIN_VERSION_template_haskell(2,9,0)+ , _AnnP+#endif+ -- ** Inline Prisms+ , _NoInline+ , _Inline+ , _Inlinable+ -- ** RuleMatch Prisms+ , _ConLike+ , _FunLike+ -- ** Phases Prisms+ , _AllPhases+ , _FromPhase+ , _BeforePhase+ -- ** RuleBndr Prisms+ , _RuleVar+ , _TypedRuleVar+#endif+#if MIN_VERSION_template_haskell(2,9,0)+ -- ** AnnTarget Prisms+ , _ModuleAnnotation+ , _TypeAnnotation+ , _ValueAnnotation+#endif+ -- ** FunDep Prisms TODO make a lens+ , _FunDep+ -- ** FamFlavour Prisms+ , _TypeFam+ , _DataFam+ -- ** FixityDirection Prisms+ , _InfixL+ , _InfixR+ , _InfixN+ -- ** Exp Prisms+ , _VarE+ , _ConE+ , _LitE+ , _AppE+ , _InfixE+ , _UInfixE+ , _ParensE+ , _LamE+#if MIN_VERSION_template_haskell(2,8,0)+ , _LamCaseE+#endif+ , _TupE+ , _UnboxedTupE+ , _CondE+#if MIN_VERSION_template_haskell(2,8,0)+ , _MultiIfE+#endif+ , _LetE+ , _CaseE+ , _DoE+ , _CompE+ , _ArithSeqE+ , _ListE+ , _SigE+ , _RecConE+ , _RecUpdE+ -- ** Body Prisms+ , _GuardedB+ , _NormalB+ -- ** Guard Prisms+ , _NormalG+ , _PatG+ -- ** Stmt Prisms+ , _BindS+ , _LetS+ , _NoBindS+ , _ParS+ -- ** Range Prisms+ , _FromR+ , _FromThenR+ , _FromToR+ , _FromThenToR+ -- ** Lit Prisms+ , _CharL+ , _StringL+ , _IntegerL+ , _RationalL+ , _IntPrimL+ , _WordPrimL+ , _FloatPrimL+ , _DoublePrimL+ , _StringPrimL+ -- ** Pat Prisms+ , _LitP+ , _VarP+ , _TupP+ , _UnboxedTupP+ , _ConP+ , _InfixP+ , _UInfixP+ , _ParensP+ , _TildeP+ , _BangP+ , _AsP+ , _WildP+ , _RecP+ , _ListP+ , _SigP+ , _ViewP+ -- ** Type Prisms+ , _ForallT+ , _AppT+ , _SigT+ , _VarT+ , _ConT+#if MIN_VERSION_template_haskell(2,8,0)+ , _PromotedT+#endif+ , _TupleT+ , _UnboxedTupleT+ , _ArrowT+ , _ListT+#if MIN_VERSION_template_haskell(2,8,0)+ , _PromotedTupleT+ , _PromotedNilT+ , _PromotedConsT+ , _StarT+ , _ConstraintT+ , _LitT+#endif+ -- ** TyVarBndr Prisms+ , _PlainTV+ , _KindedTV+#if MIN_VERSION_template_haskell(2,8,0)+ -- ** TyLit Prisms+ , _NumTyLit+ , _StrTyLit+#endif+ -- ** Pred Prisms+ , _ClassP+ , _EqualP+#if MIN_VERSION_template_haskell(2,9,0)+ -- ** Role Prisms+ , _NominalR+ , _RepresentationalR+#endif+ ) where++import Control.Applicative+import Control.Lens.At+import Control.Lens.Getter+import Control.Lens.Setter+import Control.Lens.Fold+import Control.Lens.Lens+import Control.Lens.Prism+import Control.Lens.Tuple+import Control.Lens.Traversal+import Data.Map as Map hiding (toList,map)+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Set as Set hiding (toList,map)+import Data.Set.Lens+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+#if MIN_VERSION_template_haskell(2,8,0)+import Data.Word+#endif++-- | Has a 'Name'+class HasName t where+ -- | Extract (or modify) the 'Name' of something+ name :: Lens' t Name++instance HasName TyVarBndr where+ name f (PlainTV n) = PlainTV <$> f n+ name f (KindedTV n k) = (`KindedTV` k) <$> f n++instance HasName Name where+ name = id++instance HasName Con where+ name f (NormalC n tys) = (`NormalC` tys) <$> f n+ name f (RecC n tys) = (`RecC` tys) <$> f n+ name f (InfixC l n r) = (\n' -> InfixC l n' r) <$> f n+ name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con++-- | Provides for the extraction of free type variables, and alpha renaming.+class HasTypeVars t where+ -- | When performing substitution into this traversal you're not allowed+ -- to substitute in a name that is bound internally or you'll violate+ -- the 'Traversal' laws, when in doubt generate your names with 'newName'.+ typeVarsEx :: Set Name -> Traversal' t Name++instance HasTypeVars TyVarBndr where+ typeVarsEx s f b+ | s^.contains (b^.name) = pure b+ | otherwise = name f b++instance HasTypeVars Name where+ typeVarsEx s f n+ | s^.contains n = pure n+ | otherwise = f n++instance HasTypeVars Type where+ typeVarsEx s f (VarT n) = VarT <$> typeVarsEx s f n+ typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r+ typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t+ typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty+ where s' = s `Set.union` setOf typeVars bs+ typeVarsEx _ _ t = pure t++instance HasTypeVars Pred where+ typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts+ typeVarsEx s f (EqualP l r) = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r++instance HasTypeVars Con where+ typeVarsEx s f (NormalC n ts) = NormalC n <$> traverseOf (traverse . _2) (typeVarsEx s f) ts+ typeVarsEx s f (RecC n ts) = RecC n <$> traverseOf (traverse . _3) (typeVarsEx s f) ts+ typeVarsEx s f (InfixC l n r) = InfixC <$> g l <*> pure n <*> g r+ where g (i, t) = (,) i <$> typeVarsEx s f t+ typeVarsEx s f (ForallC bs ctx c) = ForallC bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f c+ where s' = s `Set.union` setOf typeVars bs++instance HasTypeVars t => HasTypeVars [t] where+ typeVarsEx s = traverse . typeVarsEx s++-- | Traverse /free/ type variables+typeVars :: HasTypeVars t => Traversal' t Name+typeVars = typeVarsEx mempty++-- | Substitute using a map of names in for /free/ type variables+substTypeVars :: HasTypeVars t => Map Name Name -> t -> t+substTypeVars m = over typeVars $ \n -> fromMaybe n (m^.at n)++-- | Provides substitution for types+class SubstType t where+ -- | Perform substitution for types+ substType :: Map Name Type -> t -> t++instance SubstType Type where+ substType m t@(VarT n) = fromMaybe t (m^.at n)+ substType m (ForallT bs ctx ty) = ForallT bs (substType m' ctx) (substType m' ty)+ where m' = foldrOf typeVars Map.delete m bs+ substType m (SigT t k) = SigT (substType m t) k+ substType m (AppT l r) = AppT (substType m l) (substType m r)+ substType _ t = t++instance SubstType t => SubstType [t] where+ substType = map . substType++instance SubstType Pred where+ substType m (ClassP n ts) = ClassP n (substType m ts)+ substType m (EqualP l r) = substType m (EqualP l r)++-- | Provides a 'Traversal' of the types of each field of a constructor.+conFields :: Traversal' Con StrictType+conFields f (NormalC n fs) = NormalC n <$> traverse f fs+conFields f (RecC n fs) = RecC n <$> traverse sans_var fs+ where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t)+conFields f (InfixC l n r) = InfixC <$> f l <*> pure n <*> f r+conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c++-- | 'Traversal' of the types of the /named/ fields of a constructor.+conNamedFields :: Traversal' Con VarStrictType+conNamedFields f (RecC n fs) = RecC n <$> traverse f fs+conNamedFields _ c = pure c++-- Lenses and Prisms+locFileName :: Lens' Loc String+locFileName = lens loc_filename+ $ \loc fn -> loc { loc_filename = fn }++locPackage :: Lens' Loc String+locPackage = lens loc_package+ $ \loc fn -> loc { loc_package = fn }++locModule :: Lens' Loc String+locModule = lens loc_module+ $ \loc fn -> loc { loc_module = fn }++locStart :: Lens' Loc CharPos+locStart = lens loc_start+ $ \loc fn -> loc { loc_start = fn }++locEnd :: Lens' Loc CharPos+locEnd = lens loc_end+ $ \loc fn -> loc { loc_end = fn }++funDepInputs :: Lens' FunDep [Name]+funDepInputs = lens g s where+ g (FunDep xs _) = xs+ s (FunDep _ ys) xs = FunDep xs ys++funDepOutputs :: Lens' FunDep [Name]+funDepOutputs = lens g s where+ g (FunDep _ xs) = xs+ s (FunDep ys _) = FunDep ys++fieldExpName :: Lens' FieldExp Name+fieldExpName = _1++fieldExpExpression :: Lens' FieldExp Exp+fieldExpExpression = _2++fieldPatName :: Lens' FieldPat Name+fieldPatName = _1++fieldPatPattern :: Lens' FieldPat Pat+fieldPatPattern = _2++matchPattern :: Lens' Match Pat+matchPattern = lens g s where+ g (Match p _ _) = p+ s (Match _ x y) p = Match p x y++matchBody :: Lens' Match Body+matchBody = lens g s where+ g (Match _ b _) = b+ s (Match x _ y) b = Match x b y++matchDeclarations :: Lens' Match [Dec]+matchDeclarations = lens g s where+ g (Match _ _ ds) = ds+ s (Match x y _ ) = Match x y++fixityPrecedence :: Lens' Fixity Int+fixityPrecedence = lens g s where+ g (Fixity i _) = i+ s (Fixity _ x) i = Fixity i x++fixityDirection :: Lens' Fixity FixityDirection+fixityDirection = lens g s where+ g (Fixity _ d) = d+ s (Fixity i _) = Fixity i++clausePattern :: Lens' Clause [Pat]+clausePattern = lens g s where+ g (Clause ps _ _) = ps+ s (Clause _ x y) ps = Clause ps x y++clauseBody :: Lens' Clause Body+clauseBody = lens g s where+ g (Clause _ b _) = b+ s (Clause x _ y) b = Clause x b y++clauseDecs :: Lens' Clause [Dec]+clauseDecs = lens g s where+ g (Clause _ _ ds) = ds+ s (Clause x y _ ) = Clause x y++#if MIN_VERSION_template_haskell(2,8,0)+_ClassI :: Prism' Info (Dec, [InstanceDec])+_ClassI+ = prism remitter reviewer+ where+ remitter (x, y) = ClassI x y+ reviewer (ClassI x y) = Right (x, y)+ reviewer x = Left x++_ClassOpI :: Prism' Info (Name, Type, ParentName, Fixity)+_ClassOpI+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = ClassOpI x y z w+ reviewer (ClassOpI x y z w) = Right (x, y, z, w)+ reviewer x = Left x++#else+_ClassI :: Prism' Info (Dec, [Dec])+_ClassI+ = prism remitter reviewer+ where+ remitter (x, y) = ClassI x y+ reviewer (ClassI x y) = Right (x, y)+ reviewer x = Left x++_ClassOpI :: Prism' Info (Name, Type, Name, Fixity)+_ClassOpI+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = ClassOpI x y z w+ reviewer (ClassOpI x y z w) = Right (x, y, z, w)+ reviewer x = Left x+#endif++_TyConI :: Prism' Info Dec+_TyConI+ = prism remitter reviewer+ where+ remitter = TyConI+ reviewer (TyConI x) = Right x+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_FamilyI :: Prism' Info (Dec, [InstanceDec])+_FamilyI+ = prism remitter reviewer+ where+ remitter (x, y) = FamilyI x y+ reviewer (FamilyI x y) = Right (x, y)+ reviewer x = Left x++_PrimTyConI :: Prism' Info (Name, Arity, Unlifted)+_PrimTyConI+ = prism remitter reviewer+ where+ remitter (x, y, z) = PrimTyConI x y z+ reviewer (PrimTyConI x y z) = Right (x, y, z)+ reviewer x = Left x++_DataConI :: Prism' Info (Name, Type, ParentName, Fixity)+_DataConI+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = DataConI x y z w+ reviewer (DataConI x y z w) = Right (x, y, z, w)+ reviewer x = Left x+#else+_FamilyI :: Prism' Info (Dec, [Dec])+_FamilyI+ = prism remitter reviewer+ where+ remitter (x, y) = FamilyI x y+ reviewer (FamilyI x y) = Right (x, y)+ reviewer x = Left x++_PrimTyConI :: Prism' Info (Name, Int, Bool)+_PrimTyConI+ = prism remitter reviewer+ where+ remitter (x, y, z) = PrimTyConI x y z+ reviewer (PrimTyConI x y z) = Right (x, y, z)+ reviewer x = Left x++_DataConI :: Prism' Info (Name, Type, Name, Fixity)+_DataConI+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = DataConI x y z w+ reviewer (DataConI x y z w) = Right (x, y, z, w)+ reviewer x = Left x++#endif++_VarI :: Prism' Info (Name, Type, Maybe Dec, Fixity)+_VarI+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = VarI x y z w+ reviewer (VarI x y z w) = Right (x, y, z, w)+ reviewer x = Left x++_TyVarI :: Prism' Info (Name, Type)+_TyVarI+ = prism remitter reviewer+ where+ remitter (x, y) = TyVarI x y+ reviewer (TyVarI x y) = Right (x, y)+ reviewer x = Left x++_FunD :: Prism' Dec (Name, [Clause])+_FunD+ = prism remitter reviewer+ where+ remitter (x, y) = FunD x y+ reviewer (FunD x y) = Right (x, y)+ reviewer x = Left x++_ValD :: Prism' Dec (Pat, Body, [Dec])+_ValD+ = prism remitter reviewer+ where+ remitter (x, y, z) = ValD x y z+ reviewer (ValD x y z) = Right (x, y, z)+ reviewer x = Left x++_DataD :: Prism' Dec (Cxt, Name, [TyVarBndr], [Con], [Name])+_DataD+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u) = DataD x y z w u+ reviewer (DataD x y z w u) = Right (x, y, z, w, u)+ reviewer x = Left x++_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndr], Con, [Name])+_NewtypeD+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u) = NewtypeD x y z w u+ reviewer (NewtypeD x y z w u) = Right (x, y, z, w, u)+ reviewer x = Left x++_TySynD :: Prism' Dec (Name, [TyVarBndr], Type)+_TySynD+ = prism remitter reviewer+ where+ remitter (x, y, z) = TySynD x y z+ reviewer (TySynD x y z) = Right (x, y, z)+ reviewer x = Left x++_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndr], [FunDep], [Dec])+_ClassD+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u) = ClassD x y z w u+ reviewer (ClassD x y z w u) = Right (x, y, z, w, u)+ reviewer x = Left x++_InstanceD :: Prism' Dec (Cxt, Type, [Dec])+_InstanceD+ = prism remitter reviewer+ where+ remitter (x, y, z) = InstanceD x y z+ reviewer (InstanceD x y z) = Right (x, y, z)+ reviewer x = Left x++_SigD :: Prism' Dec (Name, Type)+_SigD+ = prism remitter reviewer+ where+ remitter (x, y) = SigD x y+ reviewer (SigD x y) = Right (x, y)+ reviewer x = Left x++_ForeignD :: Prism' Dec Foreign+_ForeignD+ = prism remitter reviewer+ where+ remitter = ForeignD+ reviewer (ForeignD x) = Right x+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_InfixD :: Prism' Dec (Fixity, Name)+_InfixD+ = prism remitter reviewer+ where+ remitter (x, y) = InfixD x y+ reviewer (InfixD x y) = Right (x, y)+ reviewer x = Left x+#endif++_PragmaD :: Prism' Dec Pragma+_PragmaD+ = prism remitter reviewer+ where+ remitter = PragmaD+ reviewer (PragmaD x) = Right x+ reviewer x = Left x++_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndr], Maybe Kind)+_FamilyD+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = FamilyD x y z w+ reviewer (FamilyD x y z w) = Right (x, y, z, w)+ reviewer x = Left x++_DataInstD :: Prism' Dec (Cxt, Name, [Type], [Con], [Name])+_DataInstD+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u) = DataInstD x y z w u+ reviewer (DataInstD x y z w u) = Right (x, y, z, w, u)+ reviewer x = Left x++_NewtypeInstD :: Prism' Dec (Cxt, Name, [Type], Con, [Name])+_NewtypeInstD+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u) = NewtypeInstD x y z w u+ reviewer (NewtypeInstD x y z w u) = Right (x, y, z, w, u)+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,9,0)+_TySynInstD :: Prism' Dec (Name, TySynEqn)+_TySynInstD+ = prism remitter reviewer+ where+ remitter (x, y) = TySynInstD x y+ reviewer (TySynInstD x y) = Right (x, y)+ reviewer x = Left x++_ClosedTypeFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind, [TySynEqn])+_ClosedTypeFamilyD+ = prism remitter reviewer+ where+ remitter (x, y, z, w) = ClosedTypeFamilyD x y z w+ reviewer (ClosedTypeFamilyD x y z w) = Right (x, y, z, w)+ reviewer x = Left x++_RoleAnnotD :: Prism' Dec (Name, [Role])+_RoleAnnotD+ = prism remitter reviewer+ where+ remitter (x, y) = RoleAnnotD x y+ reviewer (RoleAnnotD x y) = Right (x, y)+ reviewer x = Left x++#else+_TySynInstD :: Prism' Dec (Name, [Type], Type)+_TySynInstD+ = prism remitter reviewer+ where+ remitter (x, y, z) = TySynInstD x y z+ reviewer (TySynInstD x y z) = Right (x, y, z)+ reviewer x = Left x+#endif++_NormalC ::+ Prism' Con (Name, [StrictType])+_NormalC+ = prism remitter reviewer+ where+ remitter (x, y) = NormalC x y+ reviewer (NormalC x y) = Right (x, y)+ reviewer x = Left x++_RecC ::+ Prism' Con (Name, [VarStrictType])+_RecC+ = prism remitter reviewer+ where+ remitter (x, y) = RecC x y+ reviewer (RecC x y) = Right (x, y)+ reviewer x = Left x++_InfixC ::+ Prism' Con (StrictType,+ Name,+ StrictType)+_InfixC+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = InfixC x y z+ reviewer (InfixC x y z)+ = Right (x, y, z)+ reviewer x = Left x++_ForallC :: Prism' Con ([TyVarBndr], Cxt, Con)+_ForallC+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = ForallC x y z+ reviewer (ForallC x y z)+ = Right (x, y, z)+ reviewer x = Left x++_IsStrict :: Prism' Strict ()+_IsStrict+ = prism remitter reviewer+ where+ remitter () = IsStrict+ reviewer IsStrict = Right ()+ reviewer x = Left x++_NotStrict :: Prism' Strict ()+_NotStrict+ = prism remitter reviewer+ where+ remitter () = NotStrict+ reviewer NotStrict = Right ()+ reviewer x = Left x++_Unpacked :: Prism' Strict ()+_Unpacked+ = prism remitter reviewer+ where+ remitter () = Unpacked+ reviewer Unpacked = Right ()+ reviewer x = Left x++_ImportF :: Prism' Foreign (Callconv, Safety, String, Name, Type)+_ImportF+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u)+ = ImportF x y z w u+ reviewer (ImportF x y z w u)+ = Right (x, y, z, w, u)+ reviewer x = Left x++_ExportF :: Prism' Foreign (Callconv, String, Name, Type)+_ExportF+ = prism remitter reviewer+ where+ remitter (x, y, z, w)+ = ExportF x y z w+ reviewer (ExportF x y z w)+ = Right (x, y, z, w)+ reviewer x = Left x++_CCall :: Prism' Callconv ()+_CCall+ = prism remitter reviewer+ where+ remitter () = CCall+ reviewer CCall = Right ()+ reviewer x = Left x++_StdCall :: Prism' Callconv ()+_StdCall+ = prism remitter reviewer+ where+ remitter () = StdCall+ reviewer StdCall = Right ()+ reviewer x = Left x++_Unsafe :: Prism' Safety ()+_Unsafe+ = prism remitter reviewer+ where+ remitter () = Unsafe+ reviewer Unsafe = Right ()+ reviewer x = Left x++_Safe :: Prism' Safety ()+_Safe+ = prism remitter reviewer+ where+ remitter () = Safe+ reviewer Safe = Right ()+ reviewer x = Left x++_Interruptible :: Prism' Safety ()+_Interruptible+ = prism remitter reviewer+ where+ remitter () = Interruptible+ reviewer Interruptible = Right ()+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_InlineP :: Prism' Pragma (Name, Inline, RuleMatch, Phases)+_InlineP+ = prism remitter reviewer+ where+ remitter (x, y, z, w)+ = InlineP x y z w+ reviewer (InlineP x y z w)+ = Right (x, y, z, w)+ reviewer x = Left x++_SpecialiseP :: Prism' Pragma (Name, Type, Maybe Inline, Phases)+_SpecialiseP+ = prism remitter reviewer+ where+ remitter (x, y, z, w)+ = SpecialiseP x y z w+ reviewer (SpecialiseP x y z w)+ = Right (x, y, z, w)+ reviewer x = Left x+#else+_InlineP :: Prism' Pragma (Name, InlineSpec)+_InlineP+ = prism remitter reviewer+ where+ remitter (x, y)+ = InlineP x y+ reviewer (InlineP x y)+ = Right (x, y)+ reviewer x = Left x++_SpecialiseP :: Prism' Pragma (Name, Type, Maybe InlineSpec)+_SpecialiseP+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = SpecialiseP x y z+ reviewer (SpecialiseP x y z)+ = Right (x, y, z)+ reviewer x = Left x++-- TODO add lenses for InlineSpec+#endif++#if MIN_VERSION_template_haskell(2,8,0)+_SpecialiseInstP :: Prism' Pragma Type+_SpecialiseInstP+ = prism remitter reviewer+ where+ remitter x = SpecialiseInstP x+ reviewer (SpecialiseInstP x) = Right x+ reviewer x = Left x++_RuleP :: Prism' Pragma (String, [RuleBndr], Exp, Exp, Phases)+_RuleP+ = prism remitter reviewer+ where+ remitter (x, y, z, w, u)+ = RuleP x y z w u+ reviewer (RuleP x y z w u)+ = Right (x, y, z, w, u)+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,9,0)+_AnnP :: Prism' Pragma (AnnTarget, Exp)+_AnnP+ = prism remitter reviewer+ where+ remitter (x, y) = AnnP x y+ reviewer (AnnP x y) = Right (x, y)+ reviewer x = Left x+#endif++_NoInline :: Prism' Inline ()+_NoInline+ = prism remitter reviewer+ where+ remitter () = NoInline+ reviewer NoInline = Right ()+ reviewer x = Left x++_Inline :: Prism' Inline ()+_Inline+ = prism remitter reviewer+ where+ remitter () = Inline+ reviewer Inline = Right ()+ reviewer x = Left x++_Inlinable :: Prism' Inline ()+_Inlinable+ = prism remitter reviewer+ where+ remitter () = Inlinable+ reviewer Inlinable = Right ()+ reviewer x = Left x++_ConLike :: Prism' RuleMatch ()+_ConLike+ = prism remitter reviewer+ where+ remitter () = ConLike+ reviewer ConLike = Right ()+ reviewer x = Left x++_FunLike :: Prism' RuleMatch ()+_FunLike+ = prism remitter reviewer+ where+ remitter () = FunLike+ reviewer FunLike = Right ()+ reviewer x = Left x++_AllPhases :: Prism' Phases ()+_AllPhases+ = prism remitter reviewer+ where+ remitter () = AllPhases+ reviewer AllPhases = Right ()+ reviewer x = Left x++_FromPhase :: Prism' Phases Int+_FromPhase+ = prism remitter reviewer+ where+ remitter = FromPhase+ reviewer (FromPhase x) = Right x+ reviewer x = Left x++_BeforePhase :: Prism' Phases Int+_BeforePhase+ = prism remitter reviewer+ where+ remitter = BeforePhase+ reviewer (BeforePhase x) = Right x+ reviewer x = Left x++_RuleVar :: Prism' RuleBndr Name+_RuleVar+ = prism remitter reviewer+ where+ remitter = RuleVar+ reviewer (RuleVar x) = Right x+ reviewer x = Left x++_TypedRuleVar :: Prism' RuleBndr (Name, Type)+_TypedRuleVar+ = prism remitter reviewer+ where+ remitter (x, y) = TypedRuleVar x y+ reviewer (TypedRuleVar x y) = Right (x, y)+ reviewer x = Left x+#endif++#if MIN_VERSION_template_haskell(2,9,0)+_ModuleAnnotation :: Prism' AnnTarget ()+_ModuleAnnotation+ = prism remitter reviewer+ where+ remitter () = ModuleAnnotation+ reviewer ModuleAnnotation+ = Right ()+ reviewer x = Left x++_TypeAnnotation :: Prism' AnnTarget Name+_TypeAnnotation+ = prism remitter reviewer+ where+ remitter = TypeAnnotation+ reviewer (TypeAnnotation x)+ = Right x+ reviewer x = Left x++_ValueAnnotation :: Prism' AnnTarget Name+_ValueAnnotation+ = prism remitter reviewer+ where+ remitter = ValueAnnotation+ reviewer (ValueAnnotation x) = Right x+ reviewer x = Left x+#endif++_FunDep :: Prism' FunDep ([Name], [Name])+_FunDep+ = prism remitter reviewer+ where+ remitter (x, y) = FunDep x y+ reviewer (FunDep x y) = Right (x, y)++_TypeFam :: Prism' FamFlavour ()+_TypeFam+ = prism remitter reviewer+ where+ remitter () = TypeFam+ reviewer TypeFam = Right ()+ reviewer x = Left x++_DataFam :: Prism' FamFlavour ()+_DataFam+ = prism remitter reviewer+ where+ remitter () = DataFam+ reviewer DataFam = Right ()+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,9,0)+tySynEqnPatterns :: Lens' TySynEqn [Type]+tySynEqnPatterns = lens g s where+ g (TySynEqn xs _) = xs+ s (TySynEqn _ y) xs = (TySynEqn xs y)++tySynEqnResult :: Lens' TySynEqn Type+tySynEqnResult = lens g s where+ g (TySynEqn _ x) = x+ s (TySynEqn xs _) = TySynEqn xs+#endif++_InfixL :: Prism' FixityDirection ()+_InfixL+ = prism remitter reviewer+ where+ remitter () = InfixL+ reviewer InfixL = Right ()+ reviewer x = Left x++_InfixR :: Prism' FixityDirection ()+_InfixR+ = prism remitter reviewer+ where+ remitter () = InfixR+ reviewer InfixR = Right ()+ reviewer x = Left x++_InfixN :: Prism' FixityDirection ()+_InfixN+ = prism remitter reviewer+ where+ remitter () = InfixN+ reviewer InfixN = Right ()+ reviewer x = Left x++_VarE :: Prism' Exp Name+_VarE+ = prism remitter reviewer+ where+ remitter = VarE+ reviewer (VarE x) = Right x+ reviewer x = Left x++_ConE :: Prism' Exp Name+_ConE+ = prism remitter reviewer+ where+ remitter = ConE+ reviewer (ConE x) = Right x+ reviewer x = Left x++_LitE :: Prism' Exp Lit+_LitE+ = prism remitter reviewer+ where+ remitter = LitE+ reviewer (LitE x) = Right x+ reviewer x = Left x++_AppE :: Prism' Exp (Exp, Exp)+_AppE+ = prism remitter reviewer+ where+ remitter (x, y) = AppE x y+ reviewer (AppE x y) = Right (x, y)+ reviewer x = Left x++_InfixE :: Prism' Exp (Maybe Exp, Exp, Maybe Exp)+_InfixE+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = InfixE x y z+ reviewer (InfixE x y z)+ = Right (x, y, z)+ reviewer x = Left x++_UInfixE :: Prism' Exp (Exp, Exp, Exp)+_UInfixE+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = UInfixE x y z+ reviewer (UInfixE x y z)+ = Right (x, y, z)+ reviewer x = Left x++_ParensE :: Prism' Exp Exp+_ParensE+ = prism remitter reviewer+ where+ remitter = ParensE+ reviewer (ParensE x) = Right x+ reviewer x = Left x++_LamE :: Prism' Exp ([Pat], Exp)+_LamE+ = prism remitter reviewer+ where+ remitter (x, y) = LamE x y+ reviewer (LamE x y) = Right (x, y)+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_LamCaseE :: Prism' Exp [Match]+_LamCaseE+ = prism remitter reviewer+ where+ remitter = LamCaseE+ reviewer (LamCaseE x) = Right x+ reviewer x = Left x+#endif++_TupE :: Prism' Exp [Exp]+_TupE+ = prism remitter reviewer+ where+ remitter = TupE+ reviewer (TupE x) = Right x+ reviewer x = Left x++_UnboxedTupE :: Prism' Exp [Exp]+_UnboxedTupE+ = prism remitter reviewer+ where+ remitter = UnboxedTupE+ reviewer (UnboxedTupE x) = Right x+ reviewer x = Left x++_CondE :: Prism' Exp (Exp, Exp, Exp)+_CondE+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = CondE x y z+ reviewer (CondE x y z)+ = Right (x, y, z)+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_MultiIfE :: Prism' Exp [(Guard, Exp)]+_MultiIfE+ = prism remitter reviewer+ where+ remitter = MultiIfE+ reviewer (MultiIfE x) = Right x+ reviewer x = Left x+#endif++_LetE :: Prism' Exp ([Dec], Exp)+_LetE+ = prism remitter reviewer+ where+ remitter (x, y) = LetE x y+ reviewer (LetE x y) = Right (x, y)+ reviewer x = Left x++_CaseE :: Prism' Exp (Exp, [Match])+_CaseE+ = prism remitter reviewer+ where+ remitter (x, y) = CaseE x y+ reviewer (CaseE x y) = Right (x, y)+ reviewer x = Left x++_DoE :: Prism' Exp [Stmt]+_DoE+ = prism remitter reviewer+ where+ remitter = DoE+ reviewer (DoE x) = Right x+ reviewer x = Left x++_CompE :: Prism' Exp [Stmt]+_CompE+ = prism remitter reviewer+ where+ remitter = CompE+ reviewer (CompE x) = Right x+ reviewer x = Left x++_ArithSeqE :: Prism' Exp Range+_ArithSeqE+ = prism remitter reviewer+ where+ remitter = ArithSeqE+ reviewer (ArithSeqE x) = Right x+ reviewer x = Left x++_ListE :: Prism' Exp [Exp]+_ListE+ = prism remitter reviewer+ where+ remitter = ListE+ reviewer (ListE x) = Right x+ reviewer x = Left x++_SigE :: Prism' Exp (Exp, Type)+_SigE+ = prism remitter reviewer+ where+ remitter (x, y) = SigE x y+ reviewer (SigE x y) = Right (x, y)+ reviewer x = Left x++_RecConE :: Prism' Exp (Name, [FieldExp])+_RecConE+ = prism remitter reviewer+ where+ remitter (x, y) = RecConE x y+ reviewer (RecConE x y) = Right (x, y)+ reviewer x = Left x++_RecUpdE :: Prism' Exp (Exp, [FieldExp])+_RecUpdE+ = prism remitter reviewer+ where+ remitter (x, y) = RecUpdE x y+ reviewer (RecUpdE x y) = Right (x, y)+ reviewer x = Left x++_GuardedB :: Prism' Body [(Guard, Exp)]+_GuardedB+ = prism remitter reviewer+ where+ remitter = GuardedB+ reviewer (GuardedB x) = Right x+ reviewer x = Left x++_NormalB :: Prism' Body Exp+_NormalB+ = prism remitter reviewer+ where+ remitter = NormalB+ reviewer (NormalB x) = Right x+ reviewer x = Left x++_NormalG :: Prism' Guard Exp+_NormalG+ = prism remitter reviewer+ where+ remitter = NormalG+ reviewer (NormalG x) = Right x+ reviewer x = Left x++_PatG :: Prism' Guard [Stmt]+_PatG+ = prism remitter reviewer+ where+ remitter = PatG+ reviewer (PatG x) = Right x+ reviewer x = Left x++_BindS :: Prism' Stmt (Pat, Exp)+_BindS+ = prism remitter reviewer+ where+ remitter (x, y) = BindS x y+ reviewer (BindS x y) = Right (x, y)+ reviewer x = Left x++_LetS :: Prism' Stmt [Dec]+_LetS+ = prism remitter reviewer+ where+ remitter = LetS+ reviewer (LetS x) = Right x+ reviewer x = Left x++_NoBindS :: Prism' Stmt Exp+_NoBindS+ = prism remitter reviewer+ where+ remitter = NoBindS+ reviewer (NoBindS x) = Right x+ reviewer x = Left x++_ParS :: Prism' Stmt [[Stmt]]+_ParS+ = prism remitter reviewer+ where+ remitter = ParS+ reviewer (ParS x) = Right x+ reviewer x = Left x++_FromR :: Prism' Range Exp+_FromR+ = prism remitter reviewer+ where+ remitter = FromR+ reviewer (FromR x) = Right x+ reviewer x = Left x++_FromThenR :: Prism' Range (Exp, Exp)+_FromThenR+ = prism remitter reviewer+ where+ remitter (x, y) = FromThenR x y+ reviewer (FromThenR x y)+ = Right (x, y)+ reviewer x = Left x++_FromToR :: Prism' Range (Exp, Exp)+_FromToR+ = prism remitter reviewer+ where+ remitter (x, y) = FromToR x y+ reviewer (FromToR x y) = Right (x, y)+ reviewer x = Left x++_FromThenToR :: Prism' Range (Exp, Exp, Exp)+_FromThenToR+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = FromThenToR x y z+ reviewer (FromThenToR x y z)+ = Right (x, y, z)+ reviewer x = Left x++_CharL :: Prism' Lit Char+_CharL+ = prism remitter reviewer+ where+ remitter = CharL+ reviewer (CharL x) = Right x+ reviewer x = Left x++_StringL :: Prism' Lit String+_StringL+ = prism remitter reviewer+ where+ remitter = StringL+ reviewer (StringL x) = Right x+ reviewer x = Left x++_IntegerL :: Prism' Lit Integer+_IntegerL+ = prism remitter reviewer+ where+ remitter = IntegerL+ reviewer (IntegerL x) = Right x+ reviewer x = Left x++_RationalL :: Prism' Lit Rational+_RationalL+ = prism remitter reviewer+ where+ remitter = RationalL+ reviewer (RationalL x) = Right x+ reviewer x = Left x++_IntPrimL :: Prism' Lit Integer+_IntPrimL+ = prism remitter reviewer+ where+ remitter = IntPrimL+ reviewer (IntPrimL x) = Right x+ reviewer x = Left x++_WordPrimL :: Prism' Lit Integer+_WordPrimL+ = prism remitter reviewer+ where+ remitter = WordPrimL+ reviewer (WordPrimL x) = Right x+ reviewer x = Left x++_FloatPrimL :: Prism' Lit Rational+_FloatPrimL+ = prism remitter reviewer+ where+ remitter = FloatPrimL+ reviewer (FloatPrimL x) = Right x+ reviewer x = Left x++_DoublePrimL :: Prism' Lit Rational+_DoublePrimL+ = prism remitter reviewer+ where+ remitter = DoublePrimL+ reviewer (DoublePrimL x) = Right x+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_StringPrimL :: Prism' Lit [Word8]+_StringPrimL+ = prism remitter reviewer+ where+ remitter = StringPrimL+ reviewer (StringPrimL x) = Right x+ reviewer x = Left x+#else+_StringPrimL :: Prism' Lit String+_StringPrimL+ = prism remitter reviewer+ where+ remitter = StringPrimL+ reviewer (StringPrimL x) = Right x+ reviewer x = Left x+#endif++_LitP :: Prism' Pat Lit+_LitP+ = prism remitter reviewer+ where+ remitter = LitP+ reviewer (LitP x) = Right x+ reviewer x = Left x++_VarP :: Prism' Pat Name+_VarP+ = prism remitter reviewer+ where+ remitter = VarP+ reviewer (VarP x) = Right x+ reviewer x = Left x++_TupP :: Prism' Pat [Pat]+_TupP+ = prism remitter reviewer+ where+ remitter = TupP+ reviewer (TupP x) = Right x+ reviewer x = Left x++_UnboxedTupP :: Prism' Pat [Pat]+_UnboxedTupP+ = prism remitter reviewer+ where+ remitter = UnboxedTupP+ reviewer (UnboxedTupP x) = Right x+ reviewer x = Left x++_ConP :: Prism' Pat (Name, [Pat])+_ConP+ = prism remitter reviewer+ where+ remitter (x, y) = ConP x y+ reviewer (ConP x y) = Right (x, y)+ reviewer x = Left x++_InfixP :: Prism' Pat (Pat, Name, Pat)+_InfixP+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = InfixP x y z+ reviewer (InfixP x y z)+ = Right (x, y, z)+ reviewer x = Left x+_UInfixP :: Prism' Pat (Pat, Name, Pat)+_UInfixP+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = UInfixP x y z+ reviewer (UInfixP x y z)+ = Right (x, y, z)+ reviewer x = Left x++_ParensP :: Prism' Pat Pat+_ParensP+ = prism remitter reviewer+ where+ remitter = ParensP+ reviewer (ParensP x) = Right x+ reviewer x = Left x++_TildeP :: Prism' Pat Pat+_TildeP+ = prism remitter reviewer+ where+ remitter = TildeP+ reviewer (TildeP x) = Right x+ reviewer x = Left x++_BangP :: Prism' Pat Pat+_BangP+ = prism remitter reviewer+ where+ remitter = BangP+ reviewer (BangP x) = Right x+ reviewer x = Left x++_AsP :: Prism' Pat (Name, Pat)+_AsP+ = prism remitter reviewer+ where+ remitter (x, y) = AsP x y+ reviewer (AsP x y) = Right (x, y)+ reviewer x = Left x++_WildP :: Prism' Pat ()+_WildP+ = prism remitter reviewer+ where+ remitter () = WildP+ reviewer WildP = Right ()+ reviewer x = Left x++_RecP :: Prism' Pat (Name, [FieldPat])+_RecP+ = prism remitter reviewer+ where+ remitter (x, y) = RecP x y+ reviewer (RecP x y) = Right (x, y)+ reviewer x = Left x++_ListP :: Prism' Pat [Pat]+_ListP+ = prism remitter reviewer+ where+ remitter = ListP+ reviewer (ListP x) = Right x+ reviewer x = Left x++_SigP :: Prism' Pat (Pat, Type)+_SigP+ = prism remitter reviewer+ where+ remitter (x, y) = SigP x y+ reviewer (SigP x y) = Right (x, y)+ reviewer x = Left x++_ViewP :: Prism' Pat (Exp, Pat)+_ViewP+ = prism remitter reviewer+ where+ remitter (x, y) = ViewP x y+ reviewer (ViewP x y) = Right (x, y)+ reviewer x = Left x++_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type)+_ForallT+ = prism remitter reviewer+ where+ remitter (x, y, z)+ = ForallT x y z+ reviewer (ForallT x y z)+ = Right (x, y, z)+ reviewer x = Left x++_AppT :: Prism' Type (Type, Type)+_AppT+ = prism remitter reviewer+ where+ remitter (x, y) = AppT x y+ reviewer (AppT x y) = Right (x, y)+ reviewer x = Left x++_SigT :: Prism' Type (Type, Kind)+_SigT+ = prism remitter reviewer+ where+ remitter (x, y) = SigT x y+ reviewer (SigT x y) = Right (x, y)+ reviewer x = Left x++_VarT :: Prism' Type Name+_VarT+ = prism remitter reviewer+ where+ remitter = VarT+ reviewer (VarT x) = Right x+ reviewer x = Left x++_ConT :: Prism' Type Name+_ConT+ = prism remitter reviewer+ where+ remitter = ConT+ reviewer (ConT x) = Right x+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_PromotedT :: Prism' Type Name+_PromotedT+ = prism remitter reviewer+ where+ remitter = PromotedT+ reviewer (PromotedT x) = Right x+ reviewer x = Left x+#endif++_TupleT :: Prism' Type Int+_TupleT+ = prism remitter reviewer+ where+ remitter = TupleT+ reviewer (TupleT x) = Right x+ reviewer x = Left x++_UnboxedTupleT :: Prism' Type Int+_UnboxedTupleT+ = prism remitter reviewer+ where+ remitter = UnboxedTupleT+ reviewer (UnboxedTupleT x) = Right x+ reviewer x = Left x++_ArrowT :: Prism' Type ()+_ArrowT+ = prism remitter reviewer+ where+ remitter () = ArrowT+ reviewer ArrowT = Right ()+ reviewer x = Left x++_ListT :: Prism' Type ()+_ListT+ = prism remitter reviewer+ where+ remitter () = ListT+ reviewer ListT = Right ()+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_PromotedTupleT :: Prism' Type Int+_PromotedTupleT+ = prism remitter reviewer+ where+ remitter = PromotedTupleT+ reviewer (PromotedTupleT x) = Right x+ reviewer x = Left x++_PromotedNilT :: Prism' Type ()+_PromotedNilT+ = prism remitter reviewer+ where+ remitter () = PromotedNilT+ reviewer PromotedNilT = Right ()+ reviewer x = Left x++_PromotedConsT :: Prism' Type ()+_PromotedConsT+ = prism remitter reviewer+ where+ remitter () = PromotedConsT+ reviewer PromotedConsT = Right ()+ reviewer x = Left x++_StarT :: Prism' Type ()+_StarT+ = prism remitter reviewer+ where+ remitter () = StarT+ reviewer StarT = Right ()+ reviewer x = Left x++_ConstraintT :: Prism' Type ()+_ConstraintT+ = prism remitter reviewer+ where+ remitter () = ConstraintT+ reviewer ConstraintT = Right ()+ reviewer x = Left x++_LitT :: Prism' Type TyLit+_LitT+ = prism remitter reviewer+ where+ remitter x = LitT x+ reviewer (LitT x) = Right x+ reviewer x = Left x+#endif++_PlainTV :: Prism' TyVarBndr Name+_PlainTV+ = prism remitter reviewer+ where+ remitter = PlainTV+ reviewer (PlainTV x) = Right x+ reviewer x = Left x++_KindedTV :: Prism' TyVarBndr (Name, Kind)+_KindedTV+ = prism remitter reviewer+ where+ remitter (x, y) = KindedTV x y+ reviewer (KindedTV x y) = Right (x, y)+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,8,0)+_NumTyLit :: Prism' TyLit Integer+_NumTyLit+ = prism remitter reviewer+ where+ remitter = NumTyLit+ reviewer (NumTyLit x) = Right x+ reviewer x = Left x++_StrTyLit :: Prism' TyLit String+_StrTyLit+ = prism remitter reviewer+ where+ remitter = StrTyLit+ reviewer (StrTyLit x) = Right x+ reviewer x = Left x+#endif++_ClassP :: Prism' Pred (Name, [Type])+_ClassP+ = prism remitter reviewer+ where+ remitter (x, y) = ClassP x y+ reviewer (ClassP x y) = Right (x, y)+ reviewer x = Left x++_EqualP :: Prism' Pred (Type, Type)+_EqualP+ = prism remitter reviewer+ where+ remitter (x, y) = EqualP x y+ reviewer (EqualP x y) = Right (x, y)+ reviewer x = Left x++#if MIN_VERSION_template_haskell(2,9,0)+_NominalR :: Prism' Role ()+_NominalR+ = prism remitter reviewer+ where+ remitter () = NominalR+ reviewer NominalR = Right ()+ reviewer x = Left x++_RepresentationalR :: Prism' Role ()+_RepresentationalR+ = prism remitter reviewer+ where+ remitter () = RepresentationalR+ reviewer RepresentationalR = Right ()+ reviewer x = Left x++_PhantomR :: Prism' Role ()+_PhantomR+ = prism remitter reviewer+ where+ remitter () = PhantomR+ reviewer PhantomR = Right ()+ reviewer x = Left x++_InferR :: Prism' Role ()+_InferR+ = prism remitter reviewer+ where+ remitter () = InferR+ reviewer InferR = Right ()+ reviewer x = Left x+#endif
src/Numeric/Lens.hs view
@@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Numeric.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -16,6 +16,12 @@ , octal , decimal , hex+ -- * Arithmetic lenses+ , adding+ , subtracting+ , multiplying+ , dividing+ , exponentiating ) where import Control.Lens@@ -25,6 +31,7 @@ -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Data.Monoid (Sum(..)) -- | This 'Prism' extracts can be used to model the fact that every 'Integral' -- type is a subset of 'Integer'.@@ -111,3 +118,49 @@ -- | @'hex' = 'base' 16@ hex :: Integral a => Prism' String a hex = base 16++-- | @'adding' n = 'iso' (+n) (subtract n)@+--+-- >>> [1..3]^..traverse.adding 1000+-- [1001,1002,1003]+adding :: Num a => a -> Iso' a a+adding n = iso (+n) (subtract n)++-- | @+-- 'subtracting' n = 'iso' (subtract n) ((+n)+-- 'subtracting' n = 'from' ('adding' n)+-- @+subtracting :: Num a => a -> Iso' a a+subtracting n = iso (subtract n) (+n)++-- | @'multiplying' n = iso (*n) (/n)@+--+-- Note: This errors for n = 0+--+-- >>> 5 & multiplying 1000 +~ 3+-- 5.003+--+-- >>> let fahrenheit = multiplying (9/5).adding 32 in 230^.from fahrenheit+-- 110.0+multiplying :: (Fractional a, Eq a) => a -> Iso' a a+multiplying 0 = error "Numeric.Lens.multiplying: factor 0"+multiplying n = iso (*n) (/n)++-- | @+-- 'dividing' n = 'iso' (/n) (*n)+-- 'dividing' n = 'from' ('multiplying' n)@+--+-- Note: This errors for n = 0+dividing :: (Fractional a, Eq a) => a -> Iso' a a+dividing 0 = error "Numeric.Lens.dividing: divisor 0"+dividing n = iso (/n) (*n)++-- | @'exponentiating' n = 'iso' (**n) (**recip n)@+--+-- Note: This errors for n = 0+--+-- >>> au (exponentiating 2._Unwrapping Sum) (foldMapOf each) (3,4)+-- 5.0+exponentiating :: (Floating a, Eq a) => a -> Iso' a a+exponentiating 0 = error "Numeric.Lens.exponentiating: exponent 0"+exponentiating n = iso (**n) (**recip n)
src/System/Exit/Lens.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : System.Exit.Lens--- Copyright : (C) 2013 Edward Kmett+-- Copyright : (C) 2013-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional@@ -30,7 +30,7 @@ -- '_ExitCode' :: 'Equality'' 'ExitCode' 'ExitCode' -- '_ExitCode' :: 'Prism'' 'SomeException' 'ExitCode' -- @- _ExitCode :: Overloaded' p f t ExitCode+ _ExitCode :: Optic' p f t ExitCode instance AsExitCode p f ExitCode where _ExitCode = id@@ -46,7 +46,7 @@ -- '_ExitSuccess' :: 'Prism'' 'ExitCode' () -- '_ExitSuccess' :: 'Prism'' 'SomeException' () -- @-_ExitSuccess :: (AsExitCode p f t, Choice p, Applicative f) => Overloaded' p f t ()+_ExitSuccess :: (AsExitCode p f t, Choice p, Applicative f) => Optic' p f t () _ExitSuccess = _ExitCode . dimap seta (either id id) . right' . rmap (ExitSuccess <$) where seta ExitSuccess = Right () seta t = Left (pure t)@@ -58,7 +58,7 @@ -- '_ExitFailure' :: 'Prism'' 'ExitCode' 'Int' -- '_ExitFailure' :: 'Prism'' 'SomeException' 'Int' -- @-_ExitFailure :: (AsExitCode p f t, Choice p, Applicative f) => Overloaded' p f t Int+_ExitFailure :: (AsExitCode p f t, Choice p, Applicative f) => Optic' p f t Int _ExitFailure = _ExitCode . dimap seta (either id id) . right' . rmap (fmap ExitFailure) where seta (ExitFailure i) = Right i seta t = Left (pure t)
src/System/FilePath/Lens.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : System.FilePath.Lens--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -11,8 +11,8 @@ module System.FilePath.Lens ( -- * Operators- (</>~), (<</>~), (<.>~), (<<.>~)- , (</>=), (<</>=), (<.>=), (<<.>=)+ (</>~), (<</>~), (<<</>~), (<.>~), (<<.>~), (<<<.>~)+ , (</>=), (<</>=), (<<</>=), (<.>=), (<<.>=), (<<<.>=) -- * Lenses , basename, directory, extension, filename ) where@@ -31,8 +31,8 @@ -- $setup -- >>> :set -XNoOverloadedStrings -infixr 4 </>~, <</>~, <.>~, <<.>~-infix 4 </>=, <</>=, <.>=, <<.>=+infixr 4 </>~, <</>~, <<</>~, <.>~, <<.>~, <<<.>~+infix 4 </>=, <</>=, <<</>=, <.>=, <<.>=, <<<.>= -- | Modify the path by adding another path. --@@ -83,6 +83,14 @@ {-# INLINE (<</>=) #-} +(<<</>~) :: Optical' (->) q ((,)FilePath) s FilePath -> FilePath -> q s (FilePath, s)+l <<</>~ b = l $ \a -> (a, a </> b)+{-# INLINE (<<</>~) #-}++(<<</>=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> FilePath -> m FilePath+l <<</>= b = l %%= \a -> (a, a </> b)+{-# INLINE (<<</>=) #-}+ -- | Modify the path by adding extension. -- -- >>> both <.>~ "txt" $ ("hello","world")@@ -127,7 +135,7 @@ -- | Add an extension onto the end of the target of a 'Lens' into -- your monad's state and return the result. ----- >>> evalState (_1 <<.>= "txt") $("hello","world")+-- >>> evalState (_1 <<.>= "txt") ("hello","world") -- "hello.txt" -- -- When you do not need the result of the operation, ('<.>=') is more flexible.@@ -136,8 +144,20 @@ {-# INLINE (<<.>=) #-} +(<<<.>~) :: Optical' (->) q ((,)FilePath) s FilePath -> String -> q s (FilePath, s)+l <<<.>~ b = l $ \a -> (a, a <.> b)+{-# INLINE (<<<.>~) #-}++(<<<.>=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> String -> m FilePath+l <<<.>= b = l %%= \a -> (a, a <.> b)+{-# INLINE (<<<.>=) #-}+ -- | A 'Lens' for reading and writing to the basename --+-- Note: This is 'not' a legal 'Lens' unless the outer 'FilePath' has both a directory+-- and filename component and the generated basenames are not null and contain no directory+-- separators.+-- -- >>> basename .~ "filename" $ "path/name.png" -- "path/filename.png" basename :: Lens' FilePath FilePath@@ -147,6 +167,9 @@ -- | A 'Lens' for reading and writing to the directory --+-- Note: this is /not/ a legal 'Lens' unless the outer 'FilePath' already has a directory component,+-- and generated directories are not null.+-- -- >>> "long/path/name.txt" ^. directory -- "long/path" directory :: Lens' FilePath FilePath@@ -156,6 +179,10 @@ -- | A 'Lens' for reading and writing to the extension --+-- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated+-- extension 'FilePath' components are either null or start with 'System.FilePath.extSeparator'+-- and do not contain any internal 'System.FilePath.extSeparator's.+-- -- >>> extension .~ ".png" $ "path/name.txt" -- "path/name.png" extension :: Lens' FilePath FilePath@@ -166,6 +193,10 @@ -- | A 'Lens' for reading and writing to the full filename+--+-- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated+-- filename 'FilePath' components are not null and do not contain any+-- elements of 'System.FilePath.pathSeparators's. -- -- >>> filename .~ "name.txt" $ "path/name.png" -- "path/name.txt"
src/System/IO/Error/Lens.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : System.IO.Error.Lens--- Copyright : (C) 2012-2013 Edward Kmett+-- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -15,7 +15,6 @@ module System.IO.Error.Lens where import Control.Lens-import Control.Exception.Lens import GHC.IO.Exception import System.IO import Foreign.C.Types@@ -23,53 +22,30 @@ -- * IOException Lenses -- | Where the error happened.------ @--- 'location' :: 'Lens'' 'IOException' 'String'--- 'location' :: 'Traversal'' 'SomeException' 'String'--- @-location :: (AsIOException (->) f t, Functor f) => LensLike' f t String-location f = _IOException $ \s -> f (ioe_location s) <&> \e -> s { ioe_location = e }+location :: Lens' IOException String+location f s = f (ioe_location s) <&> \e -> s { ioe_location = e } {-# INLINE location #-} -- | Error type specific information.------ @--- 'description' :: 'Lens'' 'IOException' 'String'--- 'description' :: 'Traversal'' 'SomeException' 'String'--- @-description :: (AsIOException (->) f t, Functor f) => LensLike' f t String-description f = _IOException $ \s -> f (ioe_description s) <&> \e -> s { ioe_description = e }+description :: Lens' IOException String+description f s = f (ioe_description s) <&> \e -> s { ioe_description = e } {-# INLINE description #-} -- | The handle used by the action flagging this error.------ @--- 'handle' :: 'Lens'' 'IOException' ('Maybe' 'Handle')--- 'handle' :: 'Traversal'' 'SomeException' ('Maybe' 'Handle')--- @-handle :: (AsIOException (->) f t, Functor f) => LensLike' f t (Maybe Handle)-handle f = _IOException $ \s -> f (ioe_handle s) <&> \e -> s { ioe_handle = e }+handle :: Lens' IOException (Maybe Handle)+handle f s = f (ioe_handle s) <&> \e -> s { ioe_handle = e } {-# INLINE handle #-} -- | 'fileName' the error is related to. ----- @--- 'fileName' :: 'Lens'' 'IOException' ('Maybe' 'FilePath')--- 'fileName' :: 'Traversal'' 'SomeException' ('Maybe' 'FilePath')--- @-fileName :: (AsIOException (->) f t, Functor f) => LensLike' f t (Maybe FilePath)-fileName f = _IOException $ \s -> f (ioe_filename s) <&> \e -> s { ioe_filename = e }+fileName :: Lens' IOException (Maybe FilePath)+fileName f s = f (ioe_filename s) <&> \e -> s { ioe_filename = e } {-# INLINE fileName #-} -- | 'errno' leading to this error, if any. ----- @--- 'errno' :: 'Lens'' 'IOException' ('Maybe' 'FilePath')--- 'errno' :: 'Traversal'' 'SomeException' ('Maybe' 'FilePath')--- @-errno :: (AsIOException (->) f t, Functor f) => LensLike' f t (Maybe CInt)-errno f = _IOException $ \s -> f (ioe_errno s) <&> \e -> s { ioe_errno = e }+errno :: Lens' IOException (Maybe CInt)+errno f s = f (ioe_errno s) <&> \e -> s { ioe_errno = e } {-# INLINE errno #-} ------------------------------------------------------------------------------@@ -77,13 +53,9 @@ ------------------------------------------------------------------------------ -- | What type of error it is------ @--- 'errorType' :: 'Lens'' 'IOException' 'IOErrorType'--- 'errorType' :: 'Traversal'' 'SomeException' 'IOErrorType'--- @-errorType :: (AsIOException (->) f t, Functor f) => LensLike' f t IOErrorType-errorType f = _IOException $ \s -> f (ioe_type s) <&> \e -> s { ioe_type = e }++errorType :: Lens' IOException IOErrorType+errorType f s = f (ioe_type s) <&> \e -> s { ioe_type = e } {-# INLINE errorType #-} -- * IOErrorType Prisms
tests/doctests.hsc view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Main (doctests)--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
+ tests/hlint.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (hlint)+-- Copyright : (C) 2013-2014 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+ args <- getArgs+ hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+ unless (null hints) exitFailure
tests/hunit.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Main (hunit)--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional
tests/properties.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-}@@ -8,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Main (properties)--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental@@ -19,7 +18,6 @@ ----------------------------------------------------------------------------- module Main where - import Control.Applicative import Control.Lens import Test.QuickCheck@@ -33,74 +31,7 @@ import Data.Functor.Compose import Numeric (showHex, showOct, showSigned) import Numeric.Lens----- The first setter law:-setter_id :: Eq s => Setter' s a -> s -> Bool-setter_id l s = over l id s == s---- The second setter law:-setter_composition :: Eq s => Setter' s a -> s -> Fun a a -> Fun a a -> Bool-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 => Lens' s a -> s -> Bool-lens_set_view l s = set l (view l s) s == s--lens_view_set :: Eq a => Lens' s a -> s -> a -> Bool-lens_view_set l s a = view l (set l a s) == a--setter_set_set :: Eq s => 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 AnIso s a -> s -> Bool-iso_hither l s = s ^.cloneIso l.from l == s--iso_yon :: Eq a => Simple AnIso s a -> a -> Bool-iso_yon l a = a^.from l.cloneIso l == a--prism_yin :: Eq a => Prism' s a -> a -> Bool-prism_yin l a = preview l (review l a) == Just a--prism_yang :: Eq s => Prism' s a -> s -> Bool-prism_yang l s = maybe s (review l) (preview l s) == s--traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => LensLike' f s a -> s -> Bool-traverse_pure l s = l pure s == (pure s :: f s)--traverse_pureMaybe :: Eq s => LensLike' Maybe s a -> s -> Bool-traverse_pureMaybe = traverse_pure--traverse_pureList :: Eq s => LensLike' [] s a -> s -> Bool-traverse_pureList = traverse_pure--traverse_compose :: (Applicative f, Applicative g, Eq (f (g s)))- => 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)- => 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)- => Traversal' s a -> Property-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)- => Lens' s a -> Property-isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l--isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a)- => 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)- => Prism' s a -> Property-isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l+import Control.Lens.Properties (isIso, isLens, isPrism, isSetter, isTraversal) -- an illegal lens bad :: Lens' (Int,Int) Int@@ -128,7 +59,6 @@ prop_mapped_mapped = isSetter (mapped.mapped :: Setter' [Maybe Int] Int) prop_both = isTraversal (both :: Traversal' (Int,Int) Int)-prop_value (Fun _ k :: Fun Int Bool) = isTraversal (each.indices k :: Traversal' (Int, Int) Int) prop_traverseLeft = isTraversal (_Left :: Traversal' (Either Int Bool) Int) prop_traverseRight = isTraversal (_Right :: Traversal' (Either Int Bool) Bool) @@ -165,31 +95,6 @@ isValid = (not . null) sPos && all isValidChar sPos sPos = case s of { ('-':s') -> s'; _ -> s } isValidChar c = isAscii c && isAlphaNum c---- Control.Lens.Zipper--prop_zipper_id (NonEmpty (s :: String)) =- (zipper s & fromWithin traverse & rezip) == s &&- over traverse id s == s--prop_zipper_Rightmost (NonEmpty (s :: String)) =- (zipper s & fromWithin traverse & rightmost & view focus) ==- (zipper s & fromWithin traverse & farthest rightward & view focus)--prop_zipper_Leftmost (NonEmpty (s :: String)) =- (zipper s & fromWithin traverse & leftmost & view focus) ==- (zipper s & fromWithin traverse & farthest leftward & view focus)--prop_zipper_Rightward_fails (NonEmpty (s :: String)) =- isNothing (zipper s & rightmost & rightward) &&- isNothing (zipper s & fromWithin traverse & rightmost & rightward)--prop_zipper_Leftward_fails (NonEmpty (s :: String)) =- isNothing (zipper s & leftmost & leftward) &&- isNothing (zipper s & fromWithin traverse & leftmost & leftward)--prop_zipper_tooth_id (NonEmpty (s :: String)) =- let z = zipper s in isJust (jerkTo (tooth z) z) main :: IO () main = $defaultMainGenerator
tests/templates.hs view
@@ -3,16 +3,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Main (templates)--- Copyright : (C) 2012-13 Edward Kmett+-- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental -- Portability : non-portable ----- This test suite validates that we are able to generate usable lenses with +-- This test suite validates that we are able to generate usable lenses with -- template haskell. -- -- The commented code summarizes what will be auto-generated below@@ -25,6 +27,8 @@ data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar -- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b')+-- upgrades to:+-- baz :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } makeLenses ''Quux@@ -37,11 +41,11 @@ -- gaffer :: Simple Lens (Quark a) a -- tape :: Simple Traversal (Quark a) a -data Hadron a b = Science { _a1 :: a, _a2 :: a, _b :: b }+data Hadron a b = Science { _a1 :: a, _a2 :: a, _c :: b } makeLenses ''Hadron -- a1 :: Simple Lens (Hadron a b) a -- a2 :: Simple Lens (Hadron a b) a--- b :: Lens (Hadron a b) (Hadron a b') b b'+-- c :: Lens (Hadron a b) (Hadron a b') b b' data Perambulation a b = Mountains { _terrain :: a, _altitude :: b }@@ -96,10 +100,10 @@ data Dude a = Dude- { _dudeLevel :: Int- , _dudeAlias :: String- , _dudeLife :: ()- , _dudeThing :: a+ { dudeLevel :: Int+ , dudeAlias :: String+ , dudeLife :: ()+ , dudeThing :: a } data Lebowski a = Lebowski { _lebowskiAlias :: String@@ -110,6 +114,70 @@ makeFields ''Dude makeFields ''Lebowski++dudeDrink :: String+dudeDrink = (Dude 9 "El Duderino" () "white russian") ^. thing +lebowskiCarpet :: Maybe String+lebowskiCarpet = (Lebowski "Mr. Lebowski" 0 "" (Just "carpet")) ^. thing++declareLenses [d|+ data Quark1 a = Qualified1 { gaffer1 :: a }+ | Unqualified1 { gaffer1 :: a, tape1 :: a }+ |]+-- data Quark1 a = Qualified1 a | Unqualified1 a a+-- gaffer1 :: Lens' (Quark1 a) a+-- tape1 :: Traversal (Quark1 a) (Quark1 b) a b++declareIso [d|+ newtype WrappedInt = Wrap { unwrap :: Int }+ data New = New Int+ |]+-- newtype WrappedInt = Wrap Int+-- data New = New Int+-- wrap :: Iso' Int WrappedInt+-- unwrap :: Iso' WrappedInt Int+-- new :: Iso' Int New++declarePrisms [d|+ data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }+ |]+-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }+-- _Lit :: Prism' Exp Int+-- _Var :: Prism' Exp String+-- _Lambda :: Prism' Exp (String, Exp)++declarePrisms [d|+ data Banana = Banana Int String+ |]+-- data Banana = Banana Int String+-- banana :: Iso' (Int, String) Banana+cavendish :: Banana+cavendish = view banana (4, "Cavendish")++data family Family a b c++#if __GLASGOW_HASKELL >= 706+declareLenses [d|+ data instance Family Int (a, b) a = FamilyInt { fm0 :: (b, a), fm1 :: Int }+ |]+-- data instance Family Int (a, b) a = FamilyInt a b+-- fm0 :: Lens (Family Int (a, b) a) (Family Int (a', b') a') (b, a) (b', a')+-- fm1 :: Lens' (Family Int (a, b) a) Int+#endif++class Class a where+ data Associated a+ method :: a -> Int++declareLenses [d|+ instance Class Int where+ data Associated Int = AssociatedInt { mochi :: Double }+ method = id+ |]+-- instance Class Int where+-- data Associated Int = AssociatedInt Double+-- method = id+-- mochi :: Iso' (Associated Int) Double main :: IO () main = putStrLn "test/templates.hs: ok"
travis/cabal-apt-install view
@@ -18,10 +18,5 @@ } $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special-$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage--if ! $APT install hlint ; then- $APT install $(deps hlint)- cabal install hlint-fi+$CABAL_INSTALL_DEPS --constraint='hlint installed' "$@" # Install the rest via Hackage