lens-3.10/0000755000000000000000000000000012226700613010563 5ustar0000000000000000lens-3.10/.ghci0000644000000000000000000000012512226700613011474 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h lens-3.10/.gitignore0000644000000000000000000000010412226700613012546 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# lens-3.10/.travis.yml0000644000000000000000000000157012226700613012677 0ustar0000000000000000language: haskell before_install: # Uncomment whenever hackage is down. # - 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 install: - cabal configure -flib-Werror $mode - cabal build script: - $script && hlint src --cpp-define HLINT - scripts/stats notifications: irc: channels: - "irc.freenode.org#haskell-lens" 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" lens-3.10/.vim.custom0000644000000000000000000000137712226700613012700 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" lens-3.10/AUTHORS.markdown0000644000000000000000000000572312226700613013463 0ustar0000000000000000Lens started as a one man project by * [Edward Kmett](mailto:ekmett@gmail.com) [@ekmett](https://github.com/ekmett) But it has been greatly enriched by opening it up to community development. Many people have contributed patches, documentation, wiki pages, bug reports, test cases and massive quantities of code to `lens` including (among others): * [Shachaf Ben-Kiki](mailto:shachaf@gmail.com) [@shachaf](https://github.com/shachaf) * Elliott Hird [@ehird](https://github.com/ehird) * [Johan Kiviniemi](mailto:lens@johan.kiviniemi.name) [@ion1](https://github.com/ion1) * [Bas Dirks](mailto:ik@basdirks.eu) [@basdirks](https://github.com/basdirks) * [Eric Mertens](mailto:emertens@gmail.com) [@glguy](https://github.com/glguy) * [Michael Sloan](mailto:mgsloan@gmail.com) [@mgsloan](https://github.com/mgsloan) * [Alexander Altman](mailto:alexanderaltman@me.com) [@phtariensflame](https://github.com/phtariensflame) * [Austin Seipp](mailto:mad.one@gmail.com) [@thoughtpolice](https://github.com/thoughtpolice) * [Dag Odenhall](mailto:dag.odenhall@gmail.com) [@dag](https://github.com/dag) * [Aristid Breitkreuz](mailto:aristidb+lens@gmail.com) [@aristidb](https://github.com/aristidb) * [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) * [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) * [Oliver Charles](mailto:ollie@ocharles.org.uk) [@ocharles](https://github.com/ocharles) * Liyang HU [@liyang](https://github.com/liyang) * [Carter Schonwald](mailto:carter.schonwald@gmail.com) [@cartazio](https://github.com/cartazio) * [Mark Wright](mailto:gienah@gentoo.org) [@markwright](https://github.com/markwright) * [Nathan van Doorn](mailto:nvd1234@gmail.com) [@Taneb](https://github.com/Taneb) * Ville Tirronen [@aleator](https://github.com/aleator) * [Mikhail Vorozhtsov](mailto:mikhail.vorozhtsov@gmail.com) [@mvv](https://github.com/mvv) * [Brent Yorgey](mailto:byorgey@gmail.com) [@byorgey](https://github.com/byorgey) * [Dan Rosén](mailto:danr@chalmers.se) [@danr](https://github.com/danr) * Yair Chuchem [@yairchu](https://github.com/yairchu) * [Michael Thompson](mailto:what_is_it_to_do_anything@yahoo.com) [@michaelt](https://github.com/michaelt) * [John Wiegley](mailto:johnw@newartisans.com) [@jwiegley](https://github.com/jwiegley) * [Jonathan Fischoff](mailto:jfischoff@yahoo.com) [@jfischoff](https://github.com/jfischoff) You can watch them carry on the quest for bragging rights in the [contributors graph](https://github.com/ekmett/lens/graphs/contributors). Omission from this list is by no means an attempt to discount your contributions! Thank you for all of your help! -Edward Kmett lens-3.10/CHANGELOG.markdown0000644000000000000000000007260112226700613013624 0ustar00000000000000003.10 ---- * Switched to `bifunctors`, `comonad`, `profunctors`, and `semigroupoids` 4.0. 3.9.2 ----- * Generalized signatures for `throwing` and `throwingM`. 3.9.1 ----- * 'condensingPolicy' was updated to work with 'split' 0.2.2 3.9.0.3 ------- * Bumped dependency on `generic-deriving` again. 3.9.0.2 ------- * Bumped dependency on `generic-deriving` to enable building on GHC HEAD. 3.9.0.1 ------- * Updated the field guide image to link to imgur. Sadly the overview haddock and the haddocks are not generated in the same directory, so the haddock hook for copying the image only works locally. 3.9 ----- * Changed `Getting` to take 3 arguments instead of 5. If you need the old behavior for portability you can use `Overloaded (Accessor r) s t a b` instead of `Getting r s t a b` and it'll work consistently back through the last few releases. * Added `involuted` to `Control.Lens.Iso`. * Factored out a common `reversed` definition from all the various forms of it around the library and placed it in `Control.Lens.Iso`. * Added `binary`, `octal`, `decimal` and `hex` to `Numeric.Lens`. * Added `sans` to `Control.Lens.At`. * Improved interoperability: * Reimplemented `Gettable` as an alias for `Contravariant` and `Functor` together to derive `Getter` and `Fold`. This means you can now implement a `Getter` or `Fold` with only a Haskell 98 dependency (`contravariant`). * Removed `Reviewable`. We now use `Bifunctor` and `Profunctor` together to derive `Review`. This means you can now implement a `Review` with Haskell 98 dependencies (`profunctors` and `bifunctors`). * These changes enables more types to be defined without incurring a dependency on the `lens` package. 3.8.7.0-3.8.7.3 [maintenance releases] ----- * Fixes to dependencies and pragmas. 3.8.6 [maintenance release] ----- * Fixed an issue with `DefaultSignatures` being used outside of the appropriate `#ifdef` that caused compilation issues on GHC 7.0.2. * Generalized the signature of `prism'` * Added `\_Void` and `only` to `Control.Lens.Prism` and `devoid` to `Control.Lens.Lens`. * Added `\_Nothing` to `Control.Lens.Prism`. * Added `devoid` and `united` to `Control.Lens.Lens`. 3.8.5 ----- * Fixed more sporadic issues in doctests, caused by carrying flags from `$setup` between modules. 3.8.4 ----- * Renamed `strippingPrefix` to `prefixed`, `strippingSuffix` to `suffixed`. Left the old names as deprecated aliases. * Fixed issues with the test suite caused by `doctests` carrying flags from the `$setup` block between modules. * Benchmarks now use `generic-deriving` rather than `ghc-prim` directly, like the rest of the package. * Added `Generics.Deriving.Lens`, which is now simply re-exported from `GHC.Generics.Lens`. 3.8.3 ----- * Added `strippingSuffix` and `stripSuffix` to `Data.Data.Lens` * Added `unpackedBytes` and `unpackedChars` to `Data.ByteString.*.Lens` * Added `unpacked` to `Data.Text.*.Lens` * Added `(#)` as an infix form of `review` to ease using a `Prism` like a smart constructor in `Control.Lens.Review`. 3.8.2 ----- * Added a notion of `Handleable(handler, handler_)` to `Control.Exception.Lens` to facilitate constructing a `Handler` from an arbitrary `Fold` or `Prism`. * Added a notion of `Handler` and `catches` to and `Control.Monad.Error.Lens` to mirror the `Control.Exception` and `Control.Monad.CatchIO` constructions. * Added additional doctests and documentation. * Improved error messages and support for types with arguments in `makeFields`. 3.8.1 ----- * Fixed a bug in `makeFields` in hierarchical modules. 3.8.0.2 ------- * Fixed an issue with running the `doctests` test suite when an older version of `semigroups` is installed. 3.8 --- * Overall: * Replaced each of the different `SimpleFoo` type aliases with `Foo'` throughout. The various `Simple` aliases can still be found in `Control.Lens.Simple` but are now deprecated. * Made sweeping changes to `Iso` and `Prism` and `Indexed` lenses internally. They are now based on `profunctors`. This affects how you use `indexed` in the resulting code and dramatically changed the meaning of `Overloaded`. * Generalized combinators to pass through indices unmodified wherever possible and added indexed variants to existing combinators. There are hundreds of these changes and they would swamp this list. * `Control.Exception.Lens` * This module was created to add combinators and prisms that make it possible to work with GHC's extensible exceptions and monad transformer stacks more easily. There are knock-on changes in `Data.Dynamic.Lens`, `System.Exit.Lens`, and `System.IO.Error.Lens`. * `Control.Lens.At` * Moved `At(at)` and `Contains(contains)` and factored out `Ixed(ix)`. * Deprecated `_at` and `resultAt`. * Removed various `ordinal` and `ix` combinators, which are subsumed by `Ixed(ix)`. * `Control.Lens.Cons` * Consoldiated the various `_head`, `_tail`, `_init` and `_last` traversals that were scattered around the place into a pair of `Cons` and `Snoc` classes that provide `_Cons` and `_Snoc` prisms respectively, and combinators that build on top. * `Control.Lens.Each` * Generalized the signature of `Each` to permit it to provide an `IndexedSetter` for `((->) e)`. * `Each` now uses an `Index` type family that is shared with `At`, `Ixed` and `Contains` to indicate these operations are related. * `Control.Lens.Equality` * Added as a stronger form of `Iso` that can be used to safely cast. * Added the adverb `simply`, which can be used to simplify the types of most combinators in the library so they only take a simple lens, simple traversal, etc as their first argument instead. e.g. `simply view` forces `a ~ b`, `s ~ t` in the argument to `view`. * `Control.Lens.Fold` * Added `foldr1Of'` and `foldl1Of'`. * Added `has` and `hasn't`. * `Control.Lens.Indexed` * The various indexed combinators for each type were distributed to their respective modules. This module grew to encompass the remaining index-specifics. * Added `index` and `indices`, and removed `iwhere` and `iwhereOf`. Use `itraversed.indices even` and `bar.indices (>3)` instead. * `Control.Lens.Internal` * This module was exploded into more manageable component modules. * `Control.Lens.Iso` * `Strict(strict)` is now a `Simple Iso`. * Added `magma` and `imagma` which can be used to provide a 'debugging view' of a `Traversal`. * `Control.Lens.Lens` * Restructuring split this module out from `Control.Lens.Type` and merged the contents `Control.Lens.IndexedLens`. * `Control.Lens.Level` * This module was created to provide the breadth-first-search Traversals `levels` and `ilevels` which can be used to do (optionally depth-limited) breadth-first searches through arbitrary traversals reaching all leaves at finite depth in finite time. To use these in full accordance with the laws you should restrict yourself to commutative operations and finite containers, but they are useful even in the absence of these properties. * `Control.Lens.Loupe` * In the interest of consistency, the `Loupe` alias has been deprecated in favor of `ALens`. * `Loupe` (and `ALens`) are now defined in terms of `Pretext` rather than `Context`. This permits them to be cloned at a reduced cost reducing the call for `ReifiedLens`. * `Control.Lens.Operators` * Added this module for users who insist on qualified use, but want access to the operators. They can `import qualified Control.Lens as Lens` and `import Control.Lens.Operators` unqualified. * `Control.Lens.Prism` * Added `prism'` to construct `SimplePrism`s. * `Control.Lens.Reified` * Consolidated the various `ReifiedFoo` definitions into one module. * `Control.Lens.Representable` * This module was removed. Its functionality may be split out into a separate package, but currently the `linear` package exports is own `Linear.Core` module to provide this functionality. It was taking lots of useful names for little functionality and didn't feel like the rest of the API. * `Control.Lens.Review` * This module now factors the `review` functionality out of `Prism` and exposes `unto`, which is to `review` what `to` is to `view`. * `Control.Lens.Setter` * Added `contramapped` and `argument` for mapping over inputs. * `Control.Lens.Simple` * Removed the infix lens aliases and repurposed the module to house the now deprecated `SimpleFoo` type aliases, which were replaced universally with `Foo'`. * `Control.Lens.TH` * `makeLenses` now generates `Lens'` and `Traversal'` where appropriate * Added `makePrisms` as a generalized `makeIso` that automatically generates a `Prism` for each constructor. `makePrisms` generates names with an `_Foo` convention. This was consolidated upon throughout the library to reduce namespace conflicts between prisms and lenses. * Added `makeFields`, which generates classes for each individual field in a data type. * Added `makeWrapped`, which automatically generates a `Wrapped` instance for a newtype. * `Control.Lens.Type` * This module was repurposed to provide a single home for all the standard lens-like type aliases used when producing lenses. You still need to go to their respective modules to find the types for consuming lens-likes if you want to generate your own lens combinators * `Control.Lens.Wrapped` * Added `wrapped'` and `unwrapped'` for scenarios where you need the help with type inference. * `Control.Lens.Zipper` * Converted `Zipper` to walk a magma based on the original structure and to use indices from indexed traversals when restoring from tape. This also means that when zipping around within a balanced structure with ascending keys `moveTo` can operate in logarithmic time, but required changing the `Zipper` type to add the index type. * `Data.Bits.Lens` * Added `byteAt`. * `Data.ByteString.Lens` * `Data.ByteString.Lazy.Lens` now uses `Int64`-based indexing. * The `Traversal` for strict `ByteStrings` now construct a balanced tree up to a given grain size. This permits zipper based seeking to operate in logarithmic time and speeds up many traversals. * `Numeric.Lens` * Created. `base` shows and reads integers at base-2 through base-36. `integral` can be used as a safe `fromInteger`/`toInteger`. 3.7.6 [maintenance release] ----- * Fixed an issue with the `Complex` `Each` instance. 3.7.5 [maintenance release] ----- * Fixed an errant `LANGUAGE` pragma 3.7.4 [maintenance release] ----- * Backported the API for `ALens` and `ALens'` to support `snap` builds on old platforms. 3.7.3 [maintenance release] ----- * Removed my intra-package dependency upper bounds for my own packages. In particular this enables us to work with `semigroups` 0.9. * Switched to `transformers-compat` to avoid having unbuilding modules at the top of the documentation, and to ease 3rd party compatibility. * Updated `Setup.lhs` to be compatible with Cabal 1.17 3.7.2 [maintenance release] ----- * Bug fix for `Magnify`. It was missing functional dependencies to determine its `k` parameter from `m` or `n`. 3.7.1.2 [maintenance release] ------- * Made the doctest test suite hide all but the exact versions of packages used to build this package to avoid problems with complicated user environments. * Removed doctests based on `:t` as they are fragile and break across GHC versions. * Fixed GHC 7.0.4 compatibility by guarding `DefaultSignatures` in `Control.Lens.Each`. 3.7.1.1 [maintenance release] ------- * Removed tests that will (likely) fail in the presence of `hashable` 1.2 3.7.1 ----- * Added `preuse`, `preuses` to `Control.Lens.Fold` * Added `Each(each)` to `Control.Lens.Each` for indexed traversal of potentially monomorphic containers. * Added `indexing64` and `traversed64` for help with large containers. * Generalized the type signature of `choosing`. * Exported `unwrapped` from `Control.Lens.Wrapped`. * Support for `hashable` 1.2 * Added `(??)` to `Control.Lens.Combinators`. 3.7.0.2 ------- * Fixed flagging for Safe Haskell. * Fixed examples. * Cleaned up the statement of the Prism laws. 3.7.0.1 ------- * Corrected bounds for hashable. * Fixed compatibility with Haskell Platform 2011.4.0.0 -- you may have to install with --constraint="transformers = 0.2.2.0" to avoid getting new mtl and transformer versions installed. [3.7](https://github.com/ekmett/lens/issues?milestone=11&page=1&state=closed) ----- * Renamed `Projection` to `Prism`. * Implemented a complete redesign of the way `Iso` and `Prism` are handled internally. Any `Iso` can now be used as a `Prism`. * The `isos` combinator is no longer required. `iso` can now be used to construct an `Iso`. * Changes to the signature of `from` and `under` were necessitated by the new design. * Added `Control.Lens.Wrapped` providing a canonical isomorphism for newtypes. * Repurposed `ala` to be closer to the original design in `newtype`, but added `au` and `alaf`. * Added `_magnitude`, `_phase` and `_conjugate` to `Data.Complex.Lens`. Renamed other lenses for consistency: `_realPart`, `_imagPart`, `_polar`. * Promoted `_left` and `_right` to prisms and moved them to `Control.Lens.Prism`. * Generalized `view` and `views` to subsume the old functionality of `peruse` and `peruses`. * Generalized `review` and `reviews` to both return a `MonadReader` and to work on a `Projection`. * Added `view'`/`views'` and `use'`/`uses'` for `Simple` access to the environment/state. * Added `set'`, a `Simple` version of `set`. * Added `reuse` : `use` :: `review` : `view` and `reuses` : `uses` :: `reviews` : `views` for working a `Projection` from the current `MonadState`. * Removed many isomorphisms for various newtypes. `_const`, `identity`, `_sum`, etc. Use `wrapping Const`, `wrapping Identity`, etc. * Removed `Data.Monoid.Lens` now that its newtypes are instances of `Wrapped`, exporting the (`<>=`)-variants from `Control.Lens.*`. * Renamed `via` to `cloneIso` for consistency. * Moved `Indexed(..)` to `Control.Lens.Classes`. * Renamed `index` to `indexed` to reduce conflicts with third-party libraries. * Added `curried` and `uncurried` to `Control.Lens.Iso`. * Added `Strict(strict)` for ad hoc overloading of conversions between strict and lazy variants of `ByteString` and `Text`. * Bug fixes for `tugTo` and `jerkTo`. * These no longer traverse in the wrong direction: `scanl1Of`, `scanr1Of`, `mapAccumLOf`, and `mapAccumROf`. * Added `anon` to `Control.Lens.Iso`. * Generalized the types of the `Control.Lens.Zipper` combinators to work with other MonadPlus instances. * Added `withins` to `Control.Lens.Zipper` now that they can work better with []. * Added `singular` and `unsafeSingular` to `Control.Lens.Traversal` to assert a `Traversal` is a `Lens`, a `Fold` is a `Getter` or a `MonadicFold` is an `Action`. * Generalized `sequenceAOf_`'s type to match `sequenceA_`. * Renamed `up`/`down`/`left`/`right` to `upward`/`downward`/`leftward`/`rightward` to reduce conflicts -- in particular with `Control.Arrow`. * Readded `leftmost` and `rightmost` due to the verbosity of `farthest leftward`/`farthest rightward`. * Added `preview`/`previews`/`firstOf` and deprecated `headOf`. * Added `iview`/`iviews`/`iuse`/`iuses` to `Control.Lens.IndexedGetter`. * We've generalized the type of Bazaar and provided generalized variants of `partsOf`, etc. that used it. 3.6.0.4 [maintenance release] ------- * Added support for `test-framework` 0.8 3.6.0.3 [maintenance release] ------- * Added support for `test-framework` 0.7 3.6.0.2 [maintenance release] ------- * Added more explicit dependencies to the doctest suite. * Disabled the 'expected failure' quickcheck tests that occasionally would fail with internal QuickCheck errors. 3.6.0.1 [maintenance release] ------- * Added explicit dependency on containers and unordered-containers to the doctest suite [3.6](https://github.com/ekmett/lens/issues?milestone=9&state=closed) --- * Added `upon` (along with variants of it) to `Data.Data.Lens`, which can be used to generate a `Traversal` from a field accessor or any function that returns, unmodified, a single field that would be visited by `template`. * Added some missing `examples/` files to the distribution. * Renamed `Data.Bits.Lens.traverseBits` to `bits`. * Removed `(^!?)`, which was an alias for `(^?!)`. * Removed the need for `Trustworthy` by changing the implementation of `coerce` for `BazaarT`. * Moved BazaarT to `Control.Lens.Internal`. * Added `(<&>)` to `Control.Lens.Combinators`. * `element` and `elementOf` are now indexed traversals rather than lenses and have moved to `Control.Lens.IndexedTraversal`. This both fixes their former partiality and lets you use chain indexed combinators with them. * Added `elements` and `elementsOf` as indexed traversals for ordinal indexing into regular traversals that generalize `element` and `elementOf`. * Renamed `Data.Complex.Lens.traverseComplex` to `complex`. * Changed `Data.Complex.Lens.polarize` to a `Simple Iso`, due to the `RealFloat` constraint causing inference problems. * Renamed `traverseLeft` and `traverseRight` to `_left` and `_right` respectively. * Renamed `traverseSlice`, `traverseFrom`, and `traverseTo` in `Data.Sequence.Lens` to `sliced`, `slicedFrom`, and `slicedTo` respectively. * Renamed `traverseAt` to `_at` in `Control.Lens.IndexedTraversal`. * Renamed `traverseArray` to `_array` in `Data.Array.Lens`. * Renamed and made the combinators in `Control.Lens.Zipper` more compositional to reduce third-party naming conflicts down to just `left` and `right`. * Renamed `&=` and `|=` to `.&.=` and `.|.=` for consistency, mutatis mutandis their related operations. * Added a `Plated` instances for `Language.Haskell.TH` types. * Renamed `atIndex` and `atIndices` in `Data.Vector.Lens` and `Data.Vector.Generic.Lens` to `ordinal` and `ordinals` to match `Data.Sequence.Lens` 3.5.1 ----- * Improved SafeHaskell inference. [3.5](https://github.com/ekmett/lens/issues?milestone=8&state=closed) --- * Fixed a potential SafeHaskell issue where a user could use `undefined` to derive `unsafeCoerce`. You now have to import an explicitly Unsafe module and create an instance of `Trustworthy` for your type to cause this behavior, so if you do, it's on your head, not mine. :) * Renamed `EvilBazaar` to `BazaarT`. * Moved a lot of internals around. Most notably, `Gettable`, `Settable` and `Effective` have moved to `Control.Lens.Classes`. * Exposed `partsOf'` and `unsafePartsOf'` in `Control.Lens.Traversal` to reduce reliance on `BazaarT` in `Control.Lens.Zipper` [3.4](https://github.com/ekmett/lens/issues?milestone=7&state=closed) --- * Renamed `(%)` to `(&)` and `(^%)` to `(^&)`. This avoids the conflict with `Data.Ratio`, which was our highest priority conflict with a third party library. * Switched to a more liberal type for `ignored` * Removed some "`isplitting`" bad combinators from `Control.Lens.IndexedFold`. * Made `indexed`, `taking`, and `dropping` and `elementOf` lazier and capable of dealing with infinite traversals and infinite folds. * Improved `Indexing` to support infinite traversals and folds. * Removed some of the more redundant combinators from `Control.Lens.Plated`, which already had existing aliases in the rest of the traversal API. * Moved `partsOf`, `holesOf`, and `elementOf` into `Control.Lens.Traversal`. * Renamed `query` to `peruse` and `queries` to `peruses`. These are much less contentious names, both contain `use` in their name for analogy to `use` and `uses` and the word is about reading. * Simpler `simple`. * Added `enum` and `non` to `Control.Lens.Iso`. * Added `(^?!)` to `Control.Lens.Fold` for unsafe access to the head of a `Fold`. * Changed `_head`, `_tail`, `_init` and `_last` to traversals in `Data.List.Lens` and `Data.Sequence.Lens`. * Eliminated `traverseHead`, `traverseTail`, `traverseInit` and `traverseLast`. * `partsOf` and `unsafePartsOf` can now also be applied to a `Fold` yielding a `Getter` or to a `MonadicFold` yielding an `Action`. 3.3 --- * Redefined `simple` and moved it to `Control.Lens.Iso`. Instead of using `simple l` you can now compose `l.simple` or `simple.l` providing more nuanced control and a more compositional API. * Moved the various `foo#` combinators used to emit cleaner core into an unexported module, `Control.Lens.Unsafe`. This removes `MagicHash` from the public API. * Removed the `bazaar#` and `runBazaar#` coercions that caused issues on GHC HEAD. * Changed the default definition of `plate` to `uniplate` from `ignored`. * Added `Data.Vector.Lens` and instances for `Data.Vector`. * Added support for the `split` package, which is now part of the Haskell platform. * Removed redundant `Data.List.traverseList`. Use `itraversed` or `traverse` instead. * Moved `(:<->)` to `Control.Lens.Simple`. * Fixed a bug in `Control.Lens.TH` that was causing `makeIso` not to work. * Added `lifted` to `Control.Lens.Setter` for mapping over monads. * Added `beside` to `Control.Lens.Traversal`. * Removed the operators from `Data.List.Lens`, they broke the overall pattern of the rest of the API, and were terrible clutter. * Fixed a bug that caused `resultAt` to give wrong answers most of the time. * Changed `resultAt` to an `IndexedLens` and moved it to `Control.Lens.IndexedLens` * Changed `ignored` to an `IndexedTraversal` and moved it to `Control.Lens.IndexedTraversal` * We've relinquished the name `value`. 3.2 --- * Made `elementOf` lazier and moved it from `Control.Lens.Traversal` to `Control.Lens.Plated`. * Made `holesOf` and `partsOf` lazier to deal with infinite structures. * Resolved issue #75. We now generate nicer core for most `Setter` and `Fold` operations, and some others. * Made lenses for field access like `_1`, `_2`, etc. lazier. * Added `Control.Lens.Loupe`, which provides a limited form of `Lens` that can be read from and written to and which can compose with other lenses, but can also be returned in a list or as a monadic result, but cannot be used directly for most combinators without cloning it first. It is easier to compose than a `ReifiedLens`, but slightly slower. * Moved (`:=>`) and (`:->`) into `Control.Lens.Simple`, which is not exported by `Control.Lens` by default to reduce name conflicts with third party libraries. 3.1 --- * Simplified the type of `filtered`, so that it can be composed with other folds rather than be parameterized on one. Included the caveat that the new `filtered` is still not a legal `Traversal`, despite seeming to compose like one. * Renamed `ifiltered` to `ifiltering`, and while it still must take an indexed lens-like as an argument, I included a similar caveat about the result not being a legal `IndexedLens` when given an `IndexedLens`. The function was renamed because its signature no longer lined up with the new `filtered` and the gerundive '-ing' suffix has come to indicate an operator that transformers another lens/traversal/etc. into a new one. * Added `taking` and `dropping` to `Control.Lens.Traversal`. 3.0.6 ----- * Alpha-renamed all combinators to a new scheme. Instead of `Foo a b c d`, they now follow `Foo s t a b`. This means that you don't need to alpha rename everything in your head to work through the examples, simplifies exposition, and uses s and t for common state monad parameters. Thanks go to Shachaf Ben-Kiki for the grunt work of slogging through hundreds of definitions by hand and with regular expressions! * Restored lenses to `Trustworthy` status so they can be used with Safe Haskell once more. 3.0.5 ----- * Fixed a bug in `rights1` and `lefts1` in `Control.Lens.Zipper` which would cause them to loop forever when given a 0 offset. 3.0.4 ----- * Added `?~`, ``, `:=>`, and `:<->` as type operator aliases for `Simple Lens`, `Simple Traversal`, and `Simple Iso` respectively. [2.9](https://github.com/ekmett/lens/issues?milestone=5&state=closed) --- * Added `<<%~`, `<<.~`, `<<%=` and `<<.=` for accessing the old values targeted by a `Lens` (or a summary of those targeted by a `Traversal`) * Renamed `|>` to `%`, as `%~` is the lensed version of `%`, and moved it to `Control.Lens.Getter` along with a version `^%` with tighter precedence that can be interleaved with `^.` * Upgraded to `doctest` 0.9, which lets us factor out common `$setup` for our doctests * Renamed `merged` to `choosing`. Added a simpler `chosen` operation to mirror `both`. * Added `Control.Lens.Projection` * Renamed `traverseException` to `exception` and `traverseDynamic` to `dynamic`, upgrading them to use `Projection`. * `makeClassy` now places each generated `Lens` or `Traversal` inside the class it constructs when possible. This makes it possible for users to just export `HasFoo(..)`, rather than have to enumerate each lens in the export list. It can only do that if it creates the class. If the `createClass` flag is disabled, then it will default to the old behavior. * Added `performs` to `Control.Lens.Action` to mirror `views` in `Control.Lens.Getter`. [2.8](https://github.com/ekmett/lens/issues?milestone=4&state=closed) --- * Restored compatibility with GHC 7.2. This required a major version bump due to making some MPTC-based default signatures conditional. 2.7.0.1 ------- * Added the missing `Control.Lens.Combinators` to exported-modules! Its absence was causing it not to be included on hackage. [2.7](https://github.com/ekmett/lens/issues?milestone=3&state=closed) --- * Generalized the signature of `Getting`, `Acting` and `IndexedGetting` to help out with the common user code scenario of needing to read and then write to change types. * Documentation cleanup and additional examples. * Renamed `au` to `ala`, introducing further incompatibility with the `newtype` package, but reducing confusion. * Removed need for `Data.Map.Lens` and `Data.IntMap.Lens` by adding `TraverseMin` and `TraverseMax` to `Control.Lens.IndexedTraversal`. * Flipped fixity of `~:` and `<~:` * Added `++~`, `++=`, `<++~` and `<++=` to Data.List.Lens in response to popular demand. * Added `|>`, `<$!>` and `<$!` to `Control.Lens.Combinators`, which exports combinators that are often useful in lens-based code, but that don't strictly involve lenses. * Added an HUnit-based test suite by @orenbenkiki 2.6.1 ----- * Fixed bugs in `Traversal` code-generation. [2.6](https://github.com/ekmett/lens/issues?milestone=2&state=closed) --- * Added build option `-f-inlining` to facilitate building with the various TH 2.8 versions used by GHC 7.6 and HEAD. * Added build option `-f-template-haskell` for testing without template haskell. (Users should be able to assume TH is enabled; use this only for testing!) * Added support for generating a `Traversal` rather than a `Lens` when multiple fields map to the same name or some constructors are missing a field. * Removed `_` from the lens names in `System.FilePath.Lens`. * Added `iwhere`, `withIndices`, `withIndicesOf`, `indices` and `indicesOf` to ease work with indexed traversals * Added `assign` as an alias for `(.=)` in `Control.Lens.Setter`. * Added `~:`, `=:`, `<~:` and `<=:` to `Data.List.Lens` [2.5](https://github.com/ekmett/lens/issues?milestone=1&state=closed) --- * Added `Control.Lens.Plated`, a port of Neil Mitchell's `uniplate` that can be used on any `Traversal`. * Added `Data.Data.Lens` with smart traversals that know how to avoid traversing parts of a structure that can't contain a given type. * Added `Data.Typeable.Lens` with `_cast` and `_gcast` like `traverseData` * Renamed `IndexedStore` to `Context` now that it is used in user-visible locations, and since I also use it as `uniplate`'s notion of a context. * Renamed `Kleene` to `Bazaar` -- "a bazaar contains a bunch of stores." * Added `Comonad` instances for `Context` and `Bazaar`, so we can use stores directly as the notion of an editable context in uniplate * Compatibility with both sets of template haskell quirks for GHC 7.6.1-rc1 and the GHC 7.6.1 development head. * Renamed `children` to `branches` in `Data.Tree.Lens`. * Added `At` and `Contains` to `Control.Lens.IndexedLens`. * Added `FunctorWithIndex`, `FoldableWithIndex`, and `TraversableWithIndex` under `Control.Lens.WithIndex` * Added support for `unordered-containers`. 2.4.0.2 ------- * GHC 7.6.1 development HEAD compatibility (but broke 7.6.1-rc1) 2.4.0.1 ------- * Haddock cleanup 2.4 ----- * Added the indexed `Kleene` store to `Control.Lens.Internal` * Moved `Gettable`, `Accessor`, `Settable` and `Mutator` to `Control.Lens.Internal` * Added `cloneTraversal` to `Control.Lens.Traversal` * Renamed `clone` to `cloneLens` in `Control.Lens.Type` * Generalized the type of `zoom` to subsume `focus`. * Removed `Focus(..)` from `Control.Lens.Type`. * Factored out `Control.Lens.Isomorphic`. * Moved many private types to `Control.Lens.Internal` * Added `conFields` to `Language.Haskell.TH.Lens`. * Added `System.FilePath.Lens`. 2.3 --- * Added missing `{-# INLINE #-}` pragmas * Renamed `meanwhile` to `throughout` in `Control.Parallel.Strategies.Lens` * Added `Magnify` to `Control.Lens.Getter`. * Added `Zoom` to `Control.Lens.Type`. 2.2 --- * Added `<&=`, `<&~`, `<|=`, and `<|~` * Moved `<>~`, `<<>~`, `<>=`, and `<<>=` to `Data.Monoid.Lens` * Template Haskell now uses eager binding to avoid adding dependencies. 2.1 --- * Renamed `adjust` to `over` * Added `au`, `auf` and `under` * Added `Data.Monoid.Lens` * Increased lower dependency bound on `mtl` for cleaner installation. lens-3.10/lens.cabal0000644000000000000000000003107312226700613012514 0ustar0000000000000000name: lens category: Data, Lenses version: 3.10 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/lens/ bug-reports: http://github.com/ekmett/lens/issues copyright: Copyright (C) 2012-2013 Edward A. Kmett build-type: Custom tested-with: GHC == 7.6.3 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types commonly used from the Haskell Platform, and with tools for automatically generating lenses and isomorphisms for user-supplied data types. . The combinators in @Control.Lens@ provide a highly generic toolbox for composing 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@: . A video on how to use lenses and how they are constructed is available from youtube: . Slides can be obtained here: . 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: . A small game of @pong@ and other more complex examples that manage their state using lenses can be found in the example folder: . /Lenses, Folds and Traversals/ . The core of the hierarchy of lens-like constructions looks like: . . <> . 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. . The result is their lowest upper bound in the hierarchy (or an error if that bound doesn't exist). . For instance: . * You can use any 'Traversal' as a 'Fold' or as a 'Setter'. . * The composition of a 'Traversal' and a 'Getter' yields a 'Fold'. . /Minimizing Dependencies/ . If you want to provide lenses and traversals for your own types in your own libraries, then you can do so without incurring a dependency on this (or any other) lens package at all. . /e.g./ for a data type: . > data Foo a = Foo Int Int a . You can define lenses such as . > -- bar :: Lens' (Foo a) Int > bar :: Functor f => (Int -> f Int) -> Foo a -> f (Foo a) > bar f (Foo a b c) = fmap (\a' -> Foo a' b c) (f a) . > -- baz :: Lens (Foo a) (Foo b) a b > quux :: Functor f => (a -> f b) -> Foo a -> f (Foo b) > quux f (Foo a b c) = fmap (Foo a b) (f c) . without the need to use any type that isn't already defined in the @Prelude@. . And you can define a traversal of multiple fields with 'Control.Applicative.Applicative': . > -- traverseBarAndBaz :: Traversal' (Foo a) Int > traverseBarAndBaz :: Applicative f => (Int -> f Int) -> Foo a -> f (Foo a) > traverseBarAndBaz f (Foo a b c) = Foo <$> f a <*> f b <*> pure c . What is provided in this library is a number of stock lenses and traversals for common haskell types, a wide array of combinators for working them, and more exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). extra-source-files: .travis.yml .ghci .gitignore .vim.custom examples/LICENSE examples/lens-examples.cabal examples/*.hs examples/*.lhs examples/bf-examples/*.bf images/*.png travis/cabal-apt-install travis/config AUTHORS.markdown README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/lens.git -- Enable benchmarking against Neil Mitchell's uniplate library for comparative performance analysis. Defaults to being turned off to avoid -- the extra dependency. -- -- > cabal configure --enable-benchmarks -fbenchmark-uniplate && cabal build && cabal bench flag benchmark-uniplate default: False manual: True -- Generate inline pragmas when using template-haskell. This defaults to enabled, but you can -- -- > cabal install lens -f-inlining -- -- to shut it off to benchmark the relative performance impact, or as last ditch effort to address compile -- errors resulting from the myriad versions of template-haskell that all purport to be 2.8. flag inlining manual: True default: True -- Some 7.6.1-rc1 users report their TH still uses old style inline pragmas. This lets them turn on inlining. flag old-inline-pragmas default: False manual: True -- Make the test suites dump their template-haskell splices. flag dump-splices default: False manual: True -- You can disable the doctests test suite with -f-test-doctests flag test-doctests default: True manual: True -- You can disable the hunit test suite with -f-test-hunit flag test-hunit default: True manual: True -- Build the properties test if we're building tests flag test-properties default: True manual: True -- Disallow unsafeCoerce flag safe default: False manual: True -- Assert that we are trustworthy when we can flag trustworthy default: True manual: True flag lib-Werror default: False manual: True library build-depends: 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 && < 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.4, mtl >= 2.0.1 && < 2.2, parallel >= 3.1.0.1 && < 3.3, profunctors >= 4 && < 5, reflection >= 1.1.6 && < 2, semigroupoids >= 4 && < 5, semigroups >= 0.8.4 && < 1, split >= 0.2 && < 0.3, tagged >= 0.4.4 && < 1, template-haskell >= 2.4 && < 2.10, text >= 0.11 && < 0.12, transformers >= 0.2 && < 0.4, transformers-compat >= 0.1 && < 1, unordered-containers >= 0.2 && < 0.3, vector >= 0.9 && < 0.11, void >= 0.5 && < 1 exposed-modules: Control.Exception.Lens Control.Lens Control.Lens.Action Control.Lens.At Control.Lens.Combinators Control.Lens.Cons Control.Lens.Each Control.Lens.Equality Control.Lens.Fold Control.Lens.Getter Control.Lens.Indexed Control.Lens.Internal Control.Lens.Internal.Action Control.Lens.Internal.Bazaar Control.Lens.Internal.ByteString Control.Lens.Internal.Context Control.Lens.Internal.Deque Control.Lens.Internal.Exception Control.Lens.Internal.Fold Control.Lens.Internal.Getter Control.Lens.Internal.Indexed Control.Lens.Internal.Instances Control.Lens.Internal.Iso Control.Lens.Internal.Level Control.Lens.Internal.Magma Control.Lens.Internal.Prism Control.Lens.Internal.Review Control.Lens.Internal.Setter Control.Lens.Internal.Zipper Control.Lens.Internal.Zoom Control.Lens.Iso Control.Lens.Lens Control.Lens.Level Control.Lens.Loupe Control.Lens.Operators Control.Lens.Plated Control.Lens.Prism 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.Parallel.Strategies.Lens Control.Seq.Lens Data.Array.Lens Data.Bits.Lens Data.ByteString.Lens Data.ByteString.Strict.Lens Data.ByteString.Lazy.Lens Data.Complex.Lens Data.Data.Lens Data.Dynamic.Lens Data.HashSet.Lens Data.IntSet.Lens Data.List.Lens Data.List.Split.Lens Data.Sequence.Lens Data.Set.Lens Data.Text.Lens Data.Text.Strict.Lens Data.Text.Lazy.Lens Data.Tree.Lens Data.Typeable.Lens Data.Vector.Lens Data.Vector.Generic.Lens Generics.Deriving.Lens GHC.Generics.Lens System.Exit.Lens System.FilePath.Lens System.IO.Error.Lens Language.Haskell.TH.Lens Numeric.Lens if flag(safe) cpp-options: -DSAFE=1 if flag(trustworthy) && impl(ghc>=7.2) other-extensions: Trustworthy cpp-options: -DTRUSTWORTHY=1 if flag(old-inline-pragmas) && impl(ghc>=7.6.0.20120810) cpp-options: -DOLD_INLINE_PRAGMAS=1 if flag(inlining) cpp-options: -DINLINING if flag(lib-Werror) ghc-options: -Werror 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 -- Verify that Template Haskell expansion works test-suite templates type: exitcode-stdio-1.0 main-is: templates.hs build-depends: base, lens ghc-options: -Wall -threaded hs-source-dirs: tests if flag(dump-splices) ghc-options: -ddump-splices if impl(ghc<7.6.1) ghc-options: -Werror -- Verify the properties of lenses with QuickCheck test-suite properties type: exitcode-stdio-1.0 main-is: properties.hs ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests if !flag(test-properties) buildable: False else build-depends: base, lens, QuickCheck >= 2.4, test-framework >= 0.6, test-framework-quickcheck2 >= 0.2, test-framework-th >= 0.2, transformers test-suite hunit type: exitcode-stdio-1.0 main-is: hunit.hs ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests if !flag(test-hunit) buildable: False else build-depends: base, containers, HUnit >= 1.2, lens, mtl, test-framework >= 0.6, test-framework-hunit >= 0.2, test-framework-th >= 0.2 -- Verify the results of the examples test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs ghc-options: -Wall -threaded hs-source-dirs: tests if !flag(test-doctests) buildable: False else build-depends: base, bytestring, containers, directory >= 1.0, deepseq, doctest >= 0.9.1, filepath, generic-deriving, mtl, nats, parallel, semigroups >= 0.9, simple-reflect >= 0.3.1, split, text, unordered-containers, vector if impl(ghc<7.6.1) ghc-options: -Werror -- Basic benchmarks for the uniplate-style combinators benchmark plated type: exitcode-stdio-1.0 main-is: plated.hs ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks build-depends: base, comonad, criterion, deepseq, generic-deriving, lens, transformers if flag(benchmark-uniplate) build-depends: uniplate >= 1.6.7 && < 1.7 cpp-options: -DBENCHMARK_UNIPLATE -- Benchmarking alongside variants benchmark alongside type: exitcode-stdio-1.0 main-is: alongside.hs ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks build-depends: base, comonad, comonads-fd, criterion, deepseq, lens, transformers -- Benchmarking unsafe implementation strategies benchmark unsafe type: exitcode-stdio-1.0 main-is: unsafe.hs ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks build-depends: base, comonad, comonads-fd, criterion, deepseq, generic-deriving, lens, transformers -- Benchmarking zipper usage benchmark zipper type: exitcode-stdio-1.0 main-is: zipper.hs ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks build-depends: base, comonad, comonads-fd, criterion, deepseq, generic-deriving, lens, transformers lens-3.10/LICENSE0000644000000000000000000000266012226700613011574 0ustar0000000000000000Copyright 2012-2013 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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-3.10/README.markdown0000644000000000000000000004775412226700613013305 0ustar0000000000000000Lens: Lenses, Folds, and Traversals ================================== [![Build Status](https://secure.travis-ci.org/ekmett/lens.png)](http://travis-ci.org/ekmett/lens) This package provides families of [lenses](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Type.hs), [isomorphisms](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Iso.hs), [folds](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Fold.hs), [traversals](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Traversal.hs), [getters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Getter.hs) and [setters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Setter.hs). If you are looking for where to get started, [a crash course video](http://youtu.be/cefnmjtAolY?hd=1) on how `lens` was constructed and how to use the basics is available on youtube. It is best watched in high definition to see the slides, but the [slides](http://comonad.com/haskell/Lenses-Folds-and-Traversals-NYC.pdf) are also available if you want to use them to follow along. The [FAQ](https://github.com/ekmett/lens/wiki/FAQ), which provides links to a large number of different resources for learning about lenses and an overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [overview](https://github.com/ekmett/lens/wiki/Overview) and some [examples](https://github.com/ekmett/lens/wiki/Examples). Documentation is available through [github](http://ekmett.github.com/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. Field Guide ----------- [![Lens Hierarchy](https://s3.amazonaws.com/creately-published/h5nyo9ne1)](https://creately.com/diagram/h5nyo9ne1/LBbRz63yg4yQsTXGLtub1bQU4%3D) Examples -------- (See [`wiki/Examples`](https://github.com/ekmett/lens/wiki/Examples)) First, import `Control.Lens`. ```haskell ghci> import Control.Lens ``` Now, you can read from lenses ```haskell ghci> ("hello","world")^._2 "world" ``` and you can write to lenses. ```haskell ghci> set _2 42 ("hello","world") ("hello",42) ``` Composing lenses for reading (or writing) goes in the order an imperative programmer would expect, and just uses `(.)` from the `Prelude`. ```haskell ghci> ("hello",("world","!!!"))^._2._1 "world" ``` ```haskell ghci> set (_2._1) 42 ("hello",("world","!!!")) ("hello",(42,"!!!")) ``` You can make a `Getter` out of a pure function with `to`. ```haskell ghci> "hello"^.to length 5 ``` You can easily compose a `Getter` with a `Lens` just using `(.)`. No explicit coercion is necessary. ```haskell ghci> ("hello",("world","!!!"))^._2._2.to length 3 ``` As we saw above, you can write to lenses and these writes can change the type of the container. `(.~)` is an infix alias for `set`. ```haskell ghci> _1 .~ "hello" $ ((),"world") ("hello","world") ``` Conversely `view`, can be used as a prefix alias for `(^.)`. ```haskell ghci> view _2 (10,20) 20 ``` There are a large number of other lens variants provided by the library, in particular a `Traversal` generalizes `traverse` from `Data.Traversable`. We'll come back to those later, but continuing with just lenses: You can let the library automatically derive lenses for fields of your data type ```haskell data Foo a = Foo { _bar :: Int, _baz :: Int, _quux :: a } makeLenses ''Foo ``` This will automatically generate the following lenses: ```haskell bar, baz :: Simple 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`. 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': ```haskell mapped :: Functor f => Setter (f a) (f b) a b ``` `over` is then analogous to `fmap`, but parameterized on the Setter. ```haskell ghci> fmap succ [1,2,3] [2,3,4] ghci> over mapped succ [1,2,3] [2,3,4] ``` The benefit is that you can use any `Lens` as a `Setter`, and the composition of setters with other setters or lenses using `(.)` yields a `Setter`. ```haskell ghci> over (mapped._2) succ [(1,2),(3,4)] [(1,3),(3,5)] ``` `(%~)` is an infix alias for 'over', and the precedence lets you avoid swimming in parentheses: ```haskell ghci> _1.mapped._2.mapped %~ succ $ ([(42, "hello")],"world") ([(42, "ifmmp")],"world") ``` There are a number of combinators that resemble the `+=`, `*=`, etc. operators from C/C++ for working with the monad transformers. There are `+~`, `*~`, etc. analogues to those combinators that work functionally, returning the modified version of the structure. ```haskell ghci> both *~ 2 $ (1,2) (2,4) ``` There are combinators for manipulating the current state in a state monad as well ```haskell fresh :: MonadState Int m => m Int fresh = id <+= 1 ``` Anything you know how to do with a `Foldable` container, you can do with a `Fold` ```haskell ghci> :m + Data.Char Data.Text.Lens ghci> allOf (folded.text) isLower ["hello"^.packed, "goodbye"^.packed] True ``` You can also use this for generic programming. Combinators are included that are based on Neil Mitchell's `uniplate`, but which have been generalized to work on or as lenses, folds, and traversals. ```haskell ghci> :m + Data.Data.Lens ghci> anyOf biplate (=="world") ("hello",(),[(2::Int,"world")]) True ``` As alluded to above, anything you know how to do with a `Traversable` you can do with a `Traversal`. ```haskell ghci> mapMOf (traverse._2) (\xs -> length xs <$ putStrLn xs) [(42,"hello"),(56,"world")] "hello" "world" [(42,5),(56,5)] ``` Moreover, many of the lenses supplied are actually isomorphisms, that means you can use them directly as a lens or getter: ```haskell ghci> let hello = "hello"^.packed "hello" ghci> :t hello hello :: Text ``` but you can also flip them around and use them as a lens the other way with `from`! ```haskell ghci> hello^.from packed.to length 5 ``` You can automatically derive isomorphisms for your own newtypes with `makeIso`. e.g. ```haskell newtype Neither a b = Neither { _nor :: Either a b } deriving (Show) makeIso ''Neither ``` will automatically derive ```haskell neither :: Iso (Neither a b) (Neither c d) (Either a b) (Either c d) nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d) ``` such that ```haskell from neither = nor from nor = neither neither.nor = id nor.neither = id ``` There is also a fully operational, but simple game of [Pong](https://github.com/ekmett/lens/blob/master/examples/Pong.hs) in the [examples/](https://github.com/ekmett/lens/blob/master/examples/) folder. There are also a couple of hundred examples distributed throughout the haddock documentation. Operators ========= (See [`wiki/Operators`](https://github.com/ekmett/lens/wiki/Operators))
Combinator(s) w/ Result Stateful w/ Result Notes
Control.Lens
view,views,^. use,uses View target(s). query works like use over a MonadReader
set, .~ <.~ .= assign,<.= Replace target(s). <<.~ and <<.= return the old value
over,mapOf,%~ <%~ %= <%= Update target(s). <<%~ and <<%= return the old value
id,traverseOf,%%~ %%= Update target(s) with an Applicative or auxiliary result
+~ <+~ += <+= Add to target(s)
-~ <-~ -= <-= Subtract from target(s)
*~ <*~ *= <*= Multiply target(s)
//~ <//~ //= <//= Divide target(s)
^~ <^~ ^= <^= Raise target(s) to a non-negative Integral power
^^~ <^^~ ^^= <^^= Raise target(s) to an Integral power
**~ <**~ **= <**= Raise target(s) to an arbitrary power
||~ <||~ ||= <||= Logically or target(s)
&&~ <&&~ &&= <&&= Logically and target(s)
<>~ <<>~ <>= <<>= mappend to the target monoidal value(s)
headOf,^? Return Just the first target or Nothing
toListOf,^.. Return a list of the target(s)
perform,performs^! Perform monadic action(s)
Control.Lens (Indexed)
iover,imapOf,%@~ <%@~ %@= <%@= Update target(s) with access to the index.
withIndex,itraverseOf,%%@~ %%@= Update target(s) with an Applicative or auxiliary result with access to the index.
Data.Bits.Lens
.|.~ <.|.~ .|.= <.|.= Bitwise or target(s)
.&.~ <.&.~ .&.= <.&.= Bitwise and target(s)
System.FilePath.Lens
</>~ <</>~ </>= <</>= Append a relative path to a FilePath
<.>~ <<.>~ <.>= <<.>= Append a file extension to a FilePath
Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett lens-3.10/Setup.lhs0000644000000000000000000000467612226700613012410 0ustar0000000000000000#!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} module Main (main) where import Data.List ( nub ) import Data.Version ( showVersion ) import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import System.FilePath ( () ) main :: IO () main = defaultMainWithHooks simpleUserHooks { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags , postHaddock = \args flags pkg lbi -> do copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")] postHaddock simpleUserHooks args flags pkg lbi } haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath haddockOutputDir flags pkg = destDir where baseDir = case haddockDistPref flags of NoFlag -> "." Flag x -> x destDir = baseDir "doc" "html" display (packageName pkg) generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys \end{code} lens-3.10/benchmarks/0000755000000000000000000000000012226700613012700 5ustar0000000000000000lens-3.10/benchmarks/alongside.hs0000644000000000000000000001036412226700613015205 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} import Control.Applicative import Control.Comonad import Control.Comonad.Store.Class import Control.Lens.Internal import Control.Lens import Criterion.Main import Data.Functor.Compose import Data.Functor.Identity -- | A finally encoded Store newtype Experiment a b s = Experiment { runExperiment :: forall f. Functor f => (a -> f b) -> f s } instance Functor (Experiment a b) where fmap f (Experiment k) = Experiment (fmap f . k) {-# INLINE fmap #-} instance (a ~ b) => Comonad (Experiment a b) where extract (Experiment m) = runIdentity (m Identity) {-# INLINE extract #-} duplicate = duplicateExperiment {-# INLINE duplicate #-} -- | 'Experiment' is an indexed 'Comonad'. duplicateExperiment :: Experiment a c s -> Experiment a b (Experiment b c s) duplicateExperiment (Experiment m) = getCompose (m (Compose . fmap placebo . placebo)) {-# INLINE duplicateExperiment #-} -- | A trivial 'Experiment'. placebo :: a -> Experiment a b b placebo i = Experiment (\k -> k i) {-# INLINE placebo #-} instance (a ~ b) => ComonadStore a (Experiment a b) where pos m = posExperiment m peek d m = peekExperiment d m peeks f m = runIdentity $ runExperiment m (\c -> Identity (f c)) experiment f m = runExperiment m f posExperiment :: Experiment a b s -> a posExperiment m = getConst (runExperiment m Const) {-# INLINE posExperiment #-} peekExperiment :: b -> Experiment a b s -> s peekExperiment b m = runIdentity $ runExperiment m (\_ -> Identity b) {-# INLINE peekExperiment #-} trial :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') trial l r pfq (s,s') = fmap (\(b,t') -> (peekExperiment b x,t')) (getCompose (r (\a' -> Compose $ pfq (posExperiment x, a')) s')) where x = l placebo s {-# INLINE trial #-} posContext :: Context a b s -> a posContext (Context _ a) = a {-# INLINE posContext #-} peekContext :: b -> Context a b s -> s peekContext b (Context f _) = f b {-# INLINE peekContext #-} -- a version of alongside built with Context and product half :: LensLike (Context a b) s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') half l r pfq (s,s') = fmap (\(b,t') -> (peekContext b x,t')) (getCompose (r (\a' -> Compose $ pfq (posContext x, a')) s')) where x = l (Context id) s {-# INLINE half #-} -- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') -- {-# INLINE alongside'#-} compound :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') compound l r = lens (\(s, s') -> (view l s, view r s')) (\(s, s') (t, t') -> (set l t s, set r t' s')) {-# INLINE compound #-} compound5 :: Lens s t a b -> Lens s' t' a' b' -> Lens s'' t'' a'' b'' -> Lens s''' t''' a''' b''' -> Lens s'''' t'''' a'''' b'''' -> Lens (s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t'''')))) (a, (a', (a'', (a''', a'''')))) (b, (b', (b'', (b''', b'''')))) compound5 l l' l'' l''' l'''' = lens (\(s, (s', (s'', (s''', s'''')))) -> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) ) (\(s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t'''')))) -> (set l t s, (set l' t' s', (set l'' t'' s'', (set l''' t''' s''', set l'''' t'''' s'''')))) ) main = defaultMain [ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", 1), (2, "there!")) , bench "trial1" $ nf (view $ trial _1 _2) (("hi", 1), (2, "there!")) , bench "half1" $ nf (view $ half _1 _2) (("hi", 1), (2, "there!")) , bench "compound1" $ nf (view $ compound _1 _2) (("hi", 1), (2, "there!")) , bench "alongside5" $ nf (view $ (alongside _1 (alongside _1 (alongside _1 (alongside _1 _1))))) ((v,v),((v,v),((v,v),((v,v),(v,v))))) , bench "trial5" $ nf (view $ (trial _1 (trial _1 (trial _1 (trial _1 _1))))) ((v,v),((v,v),((v,v),((v,v),(v,v))))) , bench "half5" $ nf (view $ (half _1 (half _1 (half _1 (half _1 _1))))) ((v,v),((v,v),((v,v),((v,v),(v,v))))) , bench "compound5" $ nf (view $ compound5 _1 _1 _1 _1 _1) ((v,v),((v,v),((v,v),((v,v),(v,v))))) ] where v = 1 :: Int lens-3.10/benchmarks/plated.hs0000644000000000000000000001605012226700613014507 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# OPTIONS_GHC -funbox-strict-fields #-} import Control.Applicative import Control.Lens import Control.DeepSeq import Criterion.Main import Data.Data import Data.Data.Lens as Data #ifdef BENCHMARK_UNIPLATE import qualified Data.Generics.Uniplate.Direct as Uni import Data.Generics.Uniplate.Direct ((|*)) import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly #endif import Generics.Deriving hiding (universe) import GHC.Generics.Lens as Generic data Expr = Val !Int | Var String | Neg !Expr | Add !Expr !Expr | Sub !Expr !Expr | Mul !Expr !Expr | Div !Expr !Expr deriving (Eq,Show,Data,Typeable,Generic) instance NFData Expr where rnf (Neg a) = rnf a rnf (Add a b) = rnf a `seq` rnf b rnf (Sub a b) = rnf a `seq` rnf b rnf (Mul a b) = rnf a `seq` rnf b rnf (Div a b) = rnf a `seq` rnf b rnf (Val i) = rnf i rnf (Var s) = rnf s instance Plated Expr where plate f (Neg a) = Neg <$> f a plate f (Add a b) = Add <$> f a <*> f b plate f (Sub a b) = Sub <$> f a <*> f b plate f (Mul a b) = Mul <$> f a <*> f b plate f (Div a b) = Div <$> f a <*> f b plate _ t = pure t {-# INLINE plate #-} #ifdef BENCHMARK_UNIPLATE instance Uni.Uniplate Expr where uniplate (Neg a) = Uni.plate Neg |* a uniplate (Add a b) = Uni.plate Add |* a |* b uniplate (Sub a b) = Uni.plate Sub |* a |* b uniplate (Mul a b) = Uni.plate Mul |* a |* b uniplate (Div a b) = Uni.plate Div |* a |* b uniplate (Val i) = Uni.plate (Val i) uniplate (Var s) = Uni.plate (Var s) {-# INLINE uniplate #-} #endif main :: IO () main = defaultMain [ bench "universe" $ nf (map universe) testsExpr , bench "universeOf plate" $ nf (map (universeOf plate)) testsExpr , bench "universeOf Generic.tinplate" $ nf (map (universeOf Generic.tinplate)) testsExpr , bench "universeOf Data.tinplate" $ nf (map (universeOf Data.tinplate)) testsExpr , bench "universeOf Data.template" $ nf (map (universeOf Data.template)) testsExpr , bench "universeOf Data.uniplate" $ nf (map (universeOf Data.uniplate)) testsExpr , bench "universeOf (cloneTraversal plate)" $ nf (map (universeOf (cloneTraversal plate))) testsExpr #ifdef BENCHMARK_UNIPLATE , bench "Direct.universe" $ nf (map Uni.universe) testsExpr , bench "DataOnly.universe" $ nf (map UniDataOnly.universe) testsExpr #endif ] testsExpr :: [Expr] testsExpr = [Val 3,Val 2,Val 6,Neg (Neg (Var "dus")),Mul (Div (Add (Val 4) (Var "kxm")) (Sub (Mul (Div (Var "") (Var "")) (Var "w")) (Var "ed"))) (Var "whpd"),Val 6,Val 4,Val 2,Var "a",Val 1,Div (Var "") (Val 0),Var "",Var "",Val (-3),Val 3,Sub (Var "") (Val 2),Neg (Var "dlp"),Div (Val 0) (Var "sd"),Val (-2),Val (-3),Var "g",Mul (Val 3) (Var "i"),Val 1,Var "ul",Div (Add (Var "") (Var "")) (Mul (Div (Val 0) (Neg (Val 0))) (Neg (Neg (Mul (Var "") (Val 0))))),Var "z",Sub (Neg (Add (Var "") (Val 0))) (Var ""),Neg (Sub (Mul (Val 0) (Val 2)) (Val 5)),Val 0,Val 0,Mul (Val (-4)) (Sub (Val 5) (Neg (Div (Div (Val 0) (Sub (Neg (Sub (Val (-3)) (Mul (Mul (Var "ap") (Val 3)) (Add (Add (Add (Var "owre") (Add (Add (Var "avj") (Val 3)) (Var "vhi"))) (Mul (Val 2) (Var "hak"))) (Val 2))))) (Var "nf"))) (Add (Sub (Val 5) (Sub (Var "pkjyh") (Val 2))) (Var "lsiu"))))),Var "u",Val 1,Neg (Add (Add (Var "") (Val 1)) (Sub (Add (Add (Val (-3)) (Mul (Val 1) (Var "pfe"))) (Var "yv")) (Mul (Var "") (Var "jfq")))),Val 2,Div (Div (Div (Div (Var "xrgykq") (Mul (Var "kyfu") (Val 2))) (Sub (Var "v") (Val 0))) (Sub (Val 6) (Val 2))) (Val 3),Var "",Var "",Add (Var "ob") (Sub (Mul (Neg (Val 2)) (Val 6)) (Add (Mul (Val 6) (Sub (Add (Var "wue") (Mul (Var "hgsuj") (Neg (Div (Var "hr") (Var "ozvsb"))))) (Sub (Var "j") (Div (Var "yeyhvq") (Val (-6)))))) (Var "b"))),Div (Add (Div (Div (Neg (Val 4)) (Var "")) (Var "yfx")) (Div (Sub (Var "") (Sub (Var "np") (Mul (Val 3) (Var "mxr")))) (Mul (Var "m") (Var "kkhbf")))) (Neg (Sub (Var "yie") (Val 1))),Neg (Var ""),Var "liuh",Var "pbqg",Var "",Neg (Div (Sub (Add (Val (-1)) (Var "onynvr")) (Neg (Var "tqjsay"))) (Add (Val 4) (Var "yorkb"))),Val 1,Add (Mul (Neg (Div (Val (-1)) (Var "u"))) (Sub (Var "") (Neg (Val 1)))) (Var "h"),Var "",Add (Mul (Sub (Var "em") (Val 0)) (Add (Val (-2)) (Val 1))) (Var ""),Add (Mul (Add (Div (Add (Val 0) (Mul (Mul (Var "e") (Add (Val 1) (Var ""))) (Neg (Neg (Div (Add (Div (Neg (Val 1)) (Div (Val (-1)) (Mul (Add (Div (Val (-1)) (Mul (Mul (Val 1) (Val 1)) (Mul (Var "t") (Val (-1))))) (Val 1)) (Val 1)))) (Add (Neg (Add (Val 0) (Var "k"))) (Mul (Neg (Div (Sub (Sub (Var "u") (Val 1)) (Val 1)) (Sub (Neg (Var "")) (Sub (Var "b") (Val (-1)))))) (Neg (Var ""))))) (Val 0)))))) (Val 0)) (Var "a")) (Var "")) (Val (-1)),Var "xijsnp",Div (Var "h") (Neg (Val 5)),Div (Var "dmzlh") (Add (Val 6) (Val (-2))),Neg (Add (Val 0) (Var "")),Add (Add (Add (Sub (Val 4) (Var "nfse")) (Var "o")) (Add (Val 2) (Div (Var "mtqdx") (Val (-3))))) (Val 3),Neg (Var "c"),Var "sr",Mul (Add (Sub (Neg (Val 1)) (Sub (Div (Add (Sub (Add (Sub (Sub (Var "gd") (Mul (Var "v") (Var "d"))) (Var "")) (Val 1)) (Add (Val 2) (Var ""))) (Var "kk")) (Div (Var "fw") (Add (Val 1) (Var "f")))) (Var ""))) (Val 2)) (Add (Neg (Div (Var "") (Val 0))) (Add (Var "") (Add (Var "s") (Add (Mul (Var "") (Val (-1))) (Val 1))))),Val 1,Var "",Sub (Var "vbnzahx") (Val (-5)),Var "nl",Val 0,Add (Mul (Neg (Mul (Var "") (Var "mvil"))) (Var "")) (Neg (Var "zxl")),Val (-3),Var "",Var "e",Add (Div (Sub (Val 0) (Add (Val 5) (Val 7))) (Mul (Var "") (Var "qz"))) (Val 4),Add (Val (-1)) (Neg (Var "lk")),Add (Add (Var "u") (Mul (Val 1) (Var "h"))) (Sub (Mul (Div (Val 1) (Div (Var "t") (Neg (Var "")))) (Var "")) (Mul (Val 1) (Neg (Div (Neg (Var "")) (Var ""))))),Val 0,Val 0,Val (-7),Mul (Var "") (Val 0),Mul (Add (Val (-6)) (Add (Val 2) (Sub (Div (Var "z") (Var "gbb")) (Var "vddnpsl")))) (Add (Add (Add (Var "") (Sub (Div (Val 3) (Neg (Div (Add (Var "cfvgz") (Add (Sub (Var "htd") (Sub (Var "mhbl") (Var "un"))) (Val 3))) (Val (-3))))) (Var ""))) (Val 5)) (Neg (Mul (Val 0) (Var "sufvvj")))),Sub (Div (Neg (Add (Add (Neg (Add (Var "") (Val 0))) (Var "")) (Sub (Val 0) (Val 0)))) (Val 0)) (Add (Neg (Div (Div (Add (Sub (Add (Add (Neg (Var "")) (Val 0)) (Val 0)) (Add (Neg (Add (Neg (Var "")) (Neg (Val 0)))) (Val 0))) (Div (Val 0) (Val 0))) (Val 0)) (Val 0))) (Var "")),Var "",Sub (Div (Val 0) (Div (Add (Val 1) (Neg (Div (Neg (Var "y")) (Val 0)))) (Var ""))) (Sub (Div (Var "t") (Var "")) (Neg (Var "s"))),Mul (Div (Sub (Var "") (Var "")) (Add (Val 0) (Sub (Div (Var "yr") (Neg (Var "o"))) (Val 1)))) (Var "u"),Var "odmn",Div (Var "uddqy") (Val 3),Var "",Sub (Val 2) (Neg (Val (-1))),Div (Mul (Var "sox") (Val (-3))) (Val (-3)),Var "qv",Var "xmbnts",Var "j",Mul (Val 6) (Mul (Var "fryndq") (Neg (Val 6))),Var "",Var "",Val (-1),Val 7,Add (Var "dg") (Val 1),Neg (Val 1),Val 0,Var "xnm",Sub (Div (Div (Var "miwi") (Var "mbh")) (Val 3)) (Val 3),Neg (Val (-4)),Var "ndubxoa",Var ""] lens-3.10/benchmarks/unsafe.hs0000644000000000000000000000304712226700613014521 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main where import Control.Lens import Control.Lens.Internal import Control.Exception import Criterion.Main import Criterion.Config import GHC.Exts overS :: ASetter s t a b -> (a -> b) -> s -> t overS l f = runMutator . l (Mutator . f) {-# INLINE overS #-} mappedS :: ASetter [a] [b] a b mappedS f = Mutator . map (runMutator . f) {-# INLINE mappedS #-} overU :: ASetter s t a b -> (a -> b) -> s -> t overU = over {-# INLINE overU #-} mappedU :: ASetter [a] [b] a b mappedU = mapped {-# INLINE mappedU #-} -- Need to eta-expand for full inlining in the NOINLINE cases? -- Doesn't seem to make a difference, though. mapSN :: (a -> b) -> [a] -> [b] mapSN f l = overS mappedS f l {-# NOINLINE mapSN #-} mapSI :: (a -> b) -> [a] -> [b] mapSI f = overS mappedS f {-# INLINE mapSI #-} mapUN :: (a -> b) -> [a] -> [b] mapUN f l = overU mappedU f l {-# NOINLINE mapUN #-} mapUI :: (a -> b) -> [a] -> [b] mapUI f = overU mappedU f {-# INLINE mapUI #-} main :: IO () main = do let n = 1000 l = replicate n "hi"; f = length --l = replicate n (); f = (\ _ -> ()) --l = replicate n (); f = (\ !_ -> ()) -- strange results --l = replicate n (); f = lazy (\_ -> ()) defaultMainWith config (return ()) [ bench "map safe noinline" $ nf (mapSN f) l , bench "map safe inline" $ nf (mapSI f) l , bench "map unsafe noinline" $ nf (mapUN f) l , bench "map unsafe inline" $ nf (mapUI f) l ] where config = defaultConfig { cfgSamples = ljust 1000 } lens-3.10/benchmarks/zipper.hs0000644000000000000000000000326012226700613014546 0ustar0000000000000000module Main ( main -- :: IO () ) where import Control.Lens import Criterion.Main main :: IO () main = defaultMain [ bgroup "rezip" [ bench "rezip" $ nf tugAndRezip1 ['a'..'z'] , bench "farthest leftward" $ nf tugAndRezip2 ['a'..'z'] , bench "leftmost" $ nf tugAndRezip3 ['a'..'z'] , bench "tugTo" $ nf tugAndRezip4 ['a'..'z'] ] , bgroup "zipper creation" [ bench "over traverse id" $ nf (over traverse id) ['a'..'z'] , bench "zipper" $ nf zipTraverseRezip ['a'..'z'] ] , bgroup "downward" [ bench "downward _1" $ nf downwardAndRezip1 (['a'..'z'],['z'..'a']) , bench "fromWithin" $ nf downwardAndRezip2 (['a'..'z'],['z'..'a']) ] ] -- What's the fastest rezip of all? tugAndRezip1, tugAndRezip2, tugAndRezip3 :: String -> String tugAndRezip1 xs = zipntugs 25 xs & focus .~ 'a' & rezip tugAndRezip2 xs = zipntugs 25 xs & focus .~ 'b' & farthest leftward & rezip tugAndRezip3 xs = zipntugs 25 xs & focus .~ 'c' & leftmost & rezip tugAndRezip4 xs = zipntugs 25 xs & focus .~ 'd' & tugTo 0 & rezip zipntugs i x = zipper x & fromWithin traverse & tugs rightward i -- How fast is creating and destroying a zipper compared to -- a regular traversal? zipTraverseRezip x = zipper x & fromWithin traverse & rezip -- is 'downward' any faster than the composition of traverse? downwardAndRezip1 :: (String, String) -> (String, String) downwardAndRezip1 xs = zipper xs & downward _1 & fromWithin traverse & focus .~ 'h' & rezip downwardAndRezip2 :: (String, String) -> (String, String) downwardAndRezip2 xs = zipper xs & fromWithin (_1.traverse) & focus .~ 'g' & rezip lens-3.10/examples/0000755000000000000000000000000012226700613012401 5ustar0000000000000000lens-3.10/examples/Aeson.hs0000644000000000000000000000104612226700613014003 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} -- | -- This is a small example of how to construct a projection for a third-party library like -- @aeson@. -- -- To test this: -- -- > doctest Aeson.hs module Aeson where import Control.Lens import Data.Aeson import Data.ByteString.Lazy -- | -- >>> review aeson 5 -- "5" -- >>> [1,2,3]^.re aeson -- "[1,2,3]" -- >>> aeson.both +~ 2 $ (2,3)^.re aeson -- "[4,5]" aeson, aeson' :: (FromJSON a, ToJSON a) => Prism' ByteString a aeson = prism' encode decode aeson' = prism' encode decode' lens-3.10/examples/Brainfuck.hs0000644000000000000000000001060712226700613014645 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Brainfuck -- Copyright : (C) 2012 Edward Kmett, nand` -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : TH, Rank2, NoMonomorphismRestriction -- -- A simple interpreter for the esoteric programming language "Brainfuck" -- written using lenses and zippers. ----------------------------------------------------------------------------- module Main where import Prelude hiding (Either(..)) import Control.Lens import Control.Applicative import Control.Monad.State import Control.Monad.Writer import qualified Data.ByteString.Lazy as BS import Data.Maybe (fromMaybe, mapMaybe) import Data.Word (Word8) import System.Environment (getArgs) import System.IO -- | Brainfuck is defined to have a memory of 30000 cells. memoryCellNum :: Int memoryCellNum = 30000 -- Low level syntax form data Instr = Plus | Minus | Right | Left | Comma | Dot | Open | Close type Code = [Instr] parse :: String -> Code parse = mapMaybe (`lookup` symbols) where symbols = [ ('+', Plus ), ('-', Minus), ('<', Left), ('>', Right) , (',', Comma), ('.', Dot ), ('[', Open), (']', Close) ] -- Higher level semantic graph data Program = Succ Program | Pred Program -- Increment or decrement the current value | Next Program | Prev Program -- Shift memory left or right | Read Program | Write Program -- Input or output the current value | Halt -- End execution -- Branching semantic, used for both sides of loops | Branch { zero :: Program, nonzero :: Program } compile :: Code -> Program compile = fst . bracket [] bracket :: [Program] -> Code -> (Program, [Program]) bracket [] [] = (Halt, []) bracket _ [] = error "Mismatched opening bracket" bracket [] (Close:_) = error "Mismatched closing bracket" -- Match a closing bracket: Pop a forward continuation, push backwards bracket (c:cs) (Close : xs) = (Branch n c, n:bs) where (n, bs) = bracket cs xs -- Match an opening bracket: Pop a backwards continuation, push forwards bracket cs (Open : xs) = (Branch b n, bs) where (n, b:bs) = bracket (n:cs) xs -- Match any other symbol in the trivial way bracket cs (x:xs) = over _1 (f x) (bracket cs xs) where f Plus = Succ; f Minus = Pred f Right = Next; f Left = Prev f Comma = Read; f Dot = Write -- * State/Writer-based interpreter type Cell = Word8 type Input = [Cell] type Output = [Cell] type Memory = Top :>> [Cell] :>> Cell -- list zipper data MachineState = MachineState { _input :: [Cell] , _memory :: Memory } makeLenses ''MachineState type Interpreter = StateT MachineState (Writer Output) () -- | Initial memory configuration initial :: Input -> MachineState initial i = MachineState i (zipper (replicate memoryCellNum 0) & fromWithin traverse) interpret :: Input -> Program -> Output interpret i = execWriter . flip execStateT (initial i) . run -- | Evaluation function run :: Program -> Interpreter run Halt = return () run (Succ n) = memory.focus += 1 >> run n run (Pred n) = memory.focus -= 1 >> run n run (Next n) = memory %= wrapRight >> run n run (Prev n) = memory %= wrapLeft >> run n run (Read n) = do memory.focus <~ uses input head input %= tail run n run (Write n) = do x <- use (memory.focus) tell [x] run n run (Branch z n) = do c <- use (memory.focus) run $ if c == 0 then z else n -- | Zipper helpers wrapRight, wrapLeft :: (a :>> b) -> (a :>> b) wrapRight = liftM2 fromMaybe leftmost rightward wrapLeft = liftM2 fromMaybe rightmost leftward -- Main program action to actually run this stuff main :: IO () main = do as <- getArgs case as of -- STDIN is program [ ] -> do hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering getContents >>= eval noInput -- STDIN is input [f] -> join $ eval <$> getInput <*> readFile f -- Malformed command line _ -> putStrLn "Usage: brainfuck [program]" eval :: Input -> String -> IO () eval i = mapM_ putByte . interpret i . compile . parse where putByte = BS.putStr . BS.pack . return -- | EOF is represented as 0 getInput :: IO Input getInput = f <$> BS.getContents where f s = BS.unpack s ++ repeat 0 noInput :: Input noInput = repeat 0 lens-3.10/examples/BrainfuckFinal.hs0000644000000000000000000000703112226700613015614 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : BrainfuckFinal -- Copyright : (C) 2012 Edward Kmett, nand` -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : TH, Rank2, NoMonomorphismRestriction -- -- A simple interpreter for the esoteric programming language "Brainfuck" -- written using lenses and zippers. -- -- This version of the interpreter is 'finally encoded' without going through -- an AST. ----------------------------------------------------------------------------- module Main where import Prelude hiding (Either(..)) import Control.Lens import Control.Applicative import Control.Monad.State import Control.Monad.Writer import qualified Data.ByteString.Lazy as BS import Data.Maybe (fromMaybe, mapMaybe) import Data.Word (Word8) import System.Environment (getArgs) import System.IO -- | Brainfuck is defined to have a memory of 30000 cells. memoryCellNum :: Int memoryCellNum = 30000 -- * State/Writer-based interpreter type Cell = Word8 type Input = [Cell] type Output = [Cell] type Memory = Top :>> [Cell] :>> Cell -- list zipper data MachineState = MachineState { _input :: [Cell] , _memory :: Memory } makeLenses ''MachineState type Program = StateT MachineState (Writer Output) () compile :: String -> Program compile = fst . bracket [] branch :: Program -> Program -> Program branch z n = do c <- use (memory.focus) if c == 0 then z else n bracket :: [Program] -> String -> (Program, [Program]) bracket [] "" = (return () , []) bracket _ "" = error "Mismatched opening bracket" bracket [] (']':_) = error "Mismatched closing bracket" -- Match a closing bracket: Pop a forward continuation, push backwards bracket (c:cs) (']': xs) = (branch n c, n:bs) where (n, bs) = bracket cs xs -- Match an opening bracket: Pop a backwards continuation, push forwards bracket cs ('[': xs) = (branch b n, bs) where (n, b:bs) = bracket (n:cs) xs -- Match any other symbol in the trivial way bracket cs (x:xs) = over _1 (f x >>) (bracket cs xs) where f '+' = memory.focus += 1 f '-' = memory.focus -= 1 f '>' = memory %= wrapRight f '<' = memory %= wrapLeft f ',' = do memory.focus <~ uses input head input %= tail f '.' = do x <- use (memory.focus) tell [x] f _ = return () -- | Initial memory configuration initial :: Input -> MachineState initial i = MachineState i (zipper (replicate memoryCellNum 0) & fromWithin traverse) interpret :: Input -> Program -> Output interpret i = execWriter . flip execStateT (initial i) -- | Zipper helpers wrapRight, wrapLeft :: (a :>> b) -> (a :>> b) wrapRight = liftM2 fromMaybe leftmost rightward wrapLeft = liftM2 fromMaybe rightmost leftward -- Main program action to actually run this stuff main :: IO () main = do as <- getArgs case as of -- STDIN is program [ ] -> do hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering getContents >>= eval noInput -- STDIN is input [f] -> join $ eval <$> getInput <*> readFile f -- Malformed command line _ -> putStrLn "Usage: brainfuck [program]" eval :: Input -> String -> IO () eval i = mapM_ putByte . interpret i . compile where putByte = BS.putStr . BS.pack . return -- | EOF is represented as 0 getInput :: IO Input getInput = f <$> BS.getContents where f s = BS.unpack s ++ repeat 0 noInput :: Input noInput = repeat 0 lens-3.10/examples/lens-examples.cabal0000644000000000000000000000250212226700613016141 0ustar0000000000000000name: lens-examples category: Data, Lenses version: 0.1 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: nand maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/lens/ bug-reports: http://github.com/ekmett/lens/issues copyright: Copyright (C) 2012 Edward A. Kmett synopsis: Lenses, Folds and Traversals description: Pong Example build-type: Simple tested-with: GHC == 7.4.1 source-repository head type: git location: git://github.com/ekmett/lens.git flag pong default: True flag brainfuck default: True executable lens-pong if !flag(pong) buildable: False build-depends: base, containers >= 0.4 && < 0.6, gloss == 1.7.*, lens, mtl >= 2.0.1 && < 2.2, random == 1.0.* main-is: Pong.hs executable lens-brainfuck if !flag(brainfuck) buildable: False build-depends: base, lens, free >= 3.0, bytestring, mtl >= 2.0.1 && < 2.2, streams >= 3.0 main-is: Brainfuck.hs executable lens-brainfuck-final if !flag(brainfuck) buildable: False build-depends: base, lens, free >= 3.0, bytestring, mtl >= 2.0.1 && < 2.2, streams >= 3.0 main-is: BrainfuckFinal.hs lens-3.10/examples/LICENSE0000644000000000000000000000265312226700613013414 0ustar0000000000000000Copyright 2012 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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-3.10/examples/Plates.hs0000644000000000000000000000156412226700613014173 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} import Control.Applicative import Control.Lens import GHC.Generics import Data.Data import Data.Data.Lens data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) instance Plated Expr where plate f (Var x ) = pure (Var x) plate f (Pos x y) = Pos <$> f x <*> pure y plate f (Neg x ) = Neg <$> f x plate f (Add x y) = Add <$> f x <*> f y instance Plated Stmt where plate f (Seq xs) = Seq <$> traverse f xs plate f (Sel xs) = pure (Sel xs) plate f (Let x y) = pure (Let x y) exprs :: Traversal' Stmt Expr exprs f (Seq xs) = Seq <$> traverse (exprs f) xs exprs f (Sel xs) = Sel <$> traverse f xs exprs f (Let x y) = Let x <$> f y lens-3.10/examples/Pong.hs0000644000000000000000000001406012226700613013641 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (C) 2012 Edward Kmett, nand` -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : TH, Rank2, NoMonomorphismRestriction -- -- A simple game of pong using gloss. ----------------------------------------------------------------------------- module Main where import Control.Applicative ((<$>), (<*>)) import Control.Lens import Control.Monad.State (State, execState, get) import Control.Monad (when) import Data.Set (Set, member, empty, insert, delete) import Graphics.Gloss import Graphics.Gloss.Interface.Pure.Game import System.Random (randomRs, newStdGen) -- Some global constants gameSize = 300 windowWidth = 800 windowHeight = 600 ballRadius = 0.02 speedIncrease = 1.2 losingAccuracy = 0.9 winningAccuracy = 0.1 initialSpeed = 0.6 paddleWidth = 0.02 paddleHeight = 0.3 paddleSpeed = 1 textSize = 0.001 -- Pure data type for representing the game state data Pong = Pong { _ballPos :: Point , _ballSpeed :: Vector , _paddle1 :: Float , _paddle2 :: Float , _score :: (Int, Int) , _vectors :: [Vector] -- Since gloss doesn't cover this, we store the set of pressed keys , _keys :: Set Key } -- Some nice lenses to go with it makeLenses ''Pong -- Renamed tuple lenses for enhanced clarity with points/vectors _x = _1 _y = _2 initial :: Pong initial = Pong (0, 0) (0, 0) 0 0 (0, 0) [] empty -- Calculate the y position at which the ball will next hit (on player2's side) hitPos :: Point -> Vector -> Float hitPos (x,y) (u,v) = ypos where xdist = if u >= 0 then 1 - x else 3 + x time = xdist / abs u ydist = v * time ypos = bounce (y + ydist) o = 1 - ballRadius -- Calculate bounces iteratively bounce n | n > o = bounce ( 2 *o - n) | n < -o = bounce ((-2)*o - n) | otherwise = n -- Difficulty function accuracy :: Pong -> Float accuracy p = g . f . fromIntegral $ p^.score._1 - p^.score._2 where -- Scaling function f x = 0.04 * x + 0.5 -- Clamping function g = min losingAccuracy . max winningAccuracy -- Game update logic update :: Float -> Pong -> Pong update time = execState $ do updatePaddles time updateBall time checkBounds -- Move the ball by adding its current speed updateBall :: Float -> State Pong () updateBall time = do (u, v) <- use ballSpeed ballPos += (time * u, time * v) -- Make sure it doesn't leave the playing area ballPos.both %= clamp ballRadius -- Update the paddles updatePaddles :: Float -> State Pong () updatePaddles time = do p <- get let paddleMovement = time * paddleSpeed keyPressed key = p^.keys.contains (SpecialKey key) -- Update the player's paddle based on keys when (keyPressed KeyUp) $ paddle1 += paddleMovement when (keyPressed KeyDown) $ paddle1 -= paddleMovement -- Calculate the optimal position let optimal = hitPos (p^.ballPos) (p^.ballSpeed) acc = accuracy p target = optimal * acc + (p^.ballPos._y) * (1 - acc) dist = target - p^.paddle2 -- Move the CPU's paddle towards this optimal position as needed when (abs dist > paddleHeight/3) $ case compare dist 0 of GT -> paddle2 += paddleMovement LT -> paddle2 -= paddleMovement _ -> return () -- Make sure both paddles don't leave the playing area paddle1 %= clamp (paddleHeight/2) paddle2 %= clamp (paddleHeight/2) -- Clamp to the region (-1, 1) but with padding clamp :: Float -> Float -> Float clamp pad = max (pad - 1) . min (1 - pad) -- Check for collisions and/or scores checkBounds :: State Pong () checkBounds = do p <- get let (x,y) = p^.ballPos -- Check for collisions with the top or bottom when (abs y >= edge) $ ballSpeed._y %= negate -- Check for collisions with paddles let check paddle other | y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 = do ballSpeed._x %= negate ballSpeed._y += 3*(y - p^.paddle) -- add english ballSpeed.both *= speedIncrease | otherwise = do score.other += 1 reset when (x >= edge) $ check paddle2 _1 when (x <= -edge) $ check paddle1 _2 where edge = 1 - ballRadius -- Reset the game reset :: State Pong () reset = do ballPos .= (0, 0) ballSpeed <~ nextSpeed -- Retrieve a speed from the list, dropping it in the process nextSpeed :: State Pong Vector nextSpeed = do v:vs <- use vectors vectors .= vs return v -- Drawing a pong state to the screen draw :: Pong -> Picture draw p = scale gameSize gameSize $ Pictures [ drawBall `at` p^.ballPos , drawPaddle `at` (-paddleX, p^.paddle1) , drawPaddle `at` ( paddleX, p^.paddle2) -- Score and playing field , drawScore (p^.score) `at` (-0.1, 0.85) , rectangleWire 2 2 ] where paddleX = 1 + paddleWidth/2 p `at` (x,y) = translate x y p; infixr 1 `at` drawPaddle :: Picture drawPaddle = rectangleSolid paddleWidth paddleHeight drawBall :: Picture drawBall = circleSolid ballRadius drawScore :: (Int, Int) -> Picture drawScore (x, y) = scale textSize textSize . text $ show x ++ " " ++ show y -- Handle input by simply updating the keys set handle :: Event -> Pong -> Pong handle (EventKey k s _ _) = keys.contains k .~ (s == Down) handle _ = id -- The main program action main = do v:vs <- startingSpeeds let world = ballSpeed .~ v $ vectors .~ vs $ initial play display backColor fps world draw handle update where display = InWindow "Pong!" (windowWidth, windowHeight) (200, 200) backColor = white fps = 120 -- Generate the random list of starting speeds startingSpeeds :: IO [Vector] startingSpeeds = do rs <- randomRs (-initialSpeed, initialSpeed) <$> newStdGen return . interleave $ filter ((> 0.2) . abs) rs where interleave :: [a] -> [(a,a)] interleave (x:y:xs) = (x,y) : interleave xs interleave _ = [] lens-3.10/examples/Setup.lhs0000644000000000000000000000016512226700613014213 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain lens-3.10/examples/Turtle.hs0000644000000000000000000000243712226700613014222 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} -- | A simple Turtle-graphics demonstration for modeling the location of a turtle. -- -- This is based on the code presented by Seth Tisue at the Boston Area Scala -- Enthusiasts meeting during his lens talk. -- -- Usage: -- -- > def & forward 10 & down & color .~ red % turn (pi/2) & forward 5 module Turtle where import Control.Lens import Data.Default data Point = Point { __x, __y :: Double } deriving (Eq,Show) makeClassy ''Point instance Default Point where def = Point def def data Color = Color { __r, __g, __b :: Int } deriving (Eq,Show) makeClassy ''Color red :: Color red = Color 255 0 0 instance Default Color where def = Color def def def data Turtle = Turtle { _tPoint :: Point , _tColor :: Color , _heading :: Double , _penDown :: Bool } deriving (Eq,Show) makeClassy ''Turtle instance Default Turtle where def = Turtle def def def False instance HasPoint Turtle where point = tPoint instance HasColor Turtle where color = tColor forward :: Double -> Turtle -> Turtle forward d t = t & _y +~ d * cos (t^.heading) & _x +~ d * sin (t^.heading) turn :: Double -> Turtle -> Turtle turn d = heading +~ d up, down :: Turtle -> Turtle up = penDown .~ False down = penDown .~ True lens-3.10/examples/bf-examples/0000755000000000000000000000000012226700613014604 5ustar0000000000000000lens-3.10/examples/bf-examples/99bottles.bf0000644000000000000000000000622012226700613016753 0ustar000000000000000099 Bottles of Beer in Urban Mueller's BrainF*** (The actual name is impolite) by Ben Olmstead ANSI C interpreter available on the internet; due to constraints in comments the address below needs to have the stuff in parenthesis replaced with the appropriate symbol: http://www(dot)cats(dash)eye(dot)com/cet/soft/lang/bf/ Believe it or not this language is indeed Turing complete! Combines the speed of BASIC with the ease of INTERCAL and the readability of an IOCCC entry! >+++++++++[<+++++++++++>-]<[>[-]>[-]<<[>+>+<<-]>>[<<+>>-]>>> [-]<<<+++++++++<[>>>+<<[>+>[-]<<-]>[<+>-]>[<<++++++++++>>>+< -]<<-<-]+++++++++>[<->-]>>+>[<[-]<<+>>>-]>[-]+<<[>+>-<<-]<<< [>>+>+<<<-]>>>[<<<+>>>-]>[<+>-]<<-[>[-]<[-]]>>+<[>[-]<-]<+++ +++++[<++++++<++++++>>-]>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>- ]<<<<<<.>>[-]>[-]++++[<++++++++>-]<.>++++[<++++++++>-]<++.>+ ++++[<+++++++++>-]<.><+++++..--------.-------.>>[>>+>+<<<-]> >>[<<<+>>>-]<[<<<<++++++++++++++.>>>>-]<<<<[-]>++++[<+++++++ +>-]<.>+++++++++[<+++++++++>-]<--.---------.>+++++++[<------ ---->-]<.>++++++[<+++++++++++>-]<.+++..+++++++++++++.>++++++ ++[<---------->-]<--.>+++++++++[<+++++++++>-]<--.-.>++++++++ [<---------->-]<++.>++++++++[<++++++++++>-]<++++.----------- -.---.>+++++++[<---------->-]<+.>++++++++[<+++++++++++>-]<-. >++[<----------->-]<.+++++++++++..>+++++++++[<---------->-]< -----.---.>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>>+++ +[<++++++>-]<--.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<. ><+++++..--------.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++ ++++++++++++.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<++ +++++++>-]<--.---------.>+++++++[<---------->-]<.>++++++[<++ +++++++++>-]<.+++..+++++++++++++.>++++++++++[<---------->-]< -.---.>+++++++[<++++++++++>-]<++++.+++++++++++++.++++++++++. ------.>+++++++[<---------->-]<+.>++++++++[<++++++++++>-]<-. -.---------.>+++++++[<---------->-]<+.>+++++++[<++++++++++>- ]<--.+++++++++++.++++++++.---------.>++++++++[<---------->-] <++.>+++++[<+++++++++++++>-]<.+++++++++++++.----------.>++++ +++[<---------->-]<++.>++++++++[<++++++++++>-]<.>+++[<-----> -]<.>+++[<++++++>-]<..>+++++++++[<--------->-]<--.>+++++++[< ++++++++++>-]<+++.+++++++++++.>++++++++[<----------->-]<++++ .>+++++[<+++++++++++++>-]<.>+++[<++++++>-]<-.---.++++++.---- ---.----------.>++++++++[<----------->-]<+.---.[-]<<<->[-]>[ -]<<[>+>+<<-]>>[<<+>>-]>>>[-]<<<+++++++++<[>>>+<<[>+>[-]<<-] >[<+>-]>[<<++++++++++>>>+<-]<<-<-]+++++++++>[<->-]>>+>[<[-]< <+>>>-]>[-]+<<[>+>-<<-]<<<[>>+>+<<<-]>>>[<<<+>>>-]<>>[<+>-]< <-[>[-]<[-]]>>+<[>[-]<-]<++++++++[<++++++<++++++>>-]>>>[>+>+ <<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>[-]>[-]++++[<++++++++> -]<.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<.><+++++..--- -----.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++++++++++++++ .>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<+++++++++>-]<- -.---------.>+++++++[<---------->-]<.>++++++[<+++++++++++>-] <.+++..+++++++++++++.>++++++++[<---------->-]<--.>+++++++++[ <+++++++++>-]<--.-.>++++++++[<---------->-]<++.>++++++++[<++ ++++++++>-]<++++.------------.---.>+++++++[<---------->-]<+. >++++++++[<+++++++++++>-]<-.>++[<----------->-]<.+++++++++++ ..>+++++++++[<---------->-]<-----.---.+++.---.[-]<<<] lens-3.10/examples/bf-examples/brainfuck.bf0000644000000000000000000000065512226700613017067 0ustar0000000000000000>>>+[[-]>>[-]++>+>+++++++[<++++>>++<-]++>>+>+>+++++[>++>++++++<<-]+>>>,<++[[>[ ->>]<[>>]<<-]<[<]<+>>[>]>[<+>-[[<+>-]>]<[[[-]<]++<-[<+++++++++>[<->-]>>]>>]]<< ]<]<[[<]>[[>]>>[>>]+[<<]<[<]<+>>-]>[>]+[->>]<<<<[[<<]<[<]+<<[+>+<<-[>-->+<<-[> +<[>>+<<-]]]>[<+>-]<]++>>-->[>]>>[>>]]<<[>>+<[[<]<]>[[<<]<[<]+[-<+>>-[<<+>++>- [<->[<<+>>-]]]<[>+<-]>]>[>]>]>[>>]>>]<<[>>+>>+>>]<<[->>>>>>>>]<<[>.>>>>>>>]<<[ >->>>>>]<<[>,>>>]<<[>+>]<<[+<<]<] lens-3.10/examples/bf-examples/cat.bf0000644000000000000000000000000612226700613015660 0ustar0000000000000000,[.,] lens-3.10/examples/bf-examples/helloworld.bf0000644000000000000000000000150712226700613017273 0ustar0000000000000000Source: Wikipedia +++++ +++++ initialize counter (cell #0) to 10 [ use loop to set the next four cells to 70/100/30/10 > +++++ ++ add 7 to cell #1 > +++++ +++++ add 10 to cell #2 > +++ add 3 to cell #3 > + add 1 to cell #4 <<<< - decrement counter (cell #0) ] > ++ . print 'H' > + . print 'e' +++++ ++ . print 'l' . print 'l' +++ . print 'o' > ++ . print ' ' << +++++ +++++ +++++ . print 'W' > . print 'o' +++ . print 'r' ----- - . print 'l' ----- --- . print 'd' > + . print '!' > . print '\n' lens-3.10/examples/bf-examples/rot13.bf0000644000000000000000000000200012226700613016055 0ustar0000000000000000, [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>++++++++++++++<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>>+++++[<----->-]<<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>++++++++++++++<- [>+<-[>+<-[>+<-[>+<-[>+<- [>++++++++++++++<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>>+++++[<----->-]<<- [>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- [>++++++++++++++<- [>+<-]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] ]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]>.[-]<,] of course any function char f(char) can be made easily on the same principle [Daniel B Cristofani (cristofdathevanetdotcom) http://www.hevanet.com/cristofd/brainfuck/] lens-3.10/examples/bf-examples/triangle.bf0000644000000000000000000000316212226700613016724 0ustar0000000000000000[ This program prints Sierpinski triangle on 80-column display. ] > + + + + [ < + + + + + + + + > - ] > + + + + + + + + [ > + + + + < - ] > > + + > > > + > > > + < < < < < < < < < < [ - [ - > + < ] > [ - < + > > > . < < ] > > > [ [ - > + + + + + + + + [ > + + + + < - ] > . < < [ - > + < ] + > [ - > + + + + + + + + + + < < + > ] > . [ - ] > ] ] + < < < [ - [ - > + < ] + > [ - < + > > > - [ - > + < ] + + > [ - < - > ] < < < ] < < < < ] + + + + + + + + + + . + + + . [ - ] < ] + + + + + * * * * * M a d e * B y : * N Y Y R I K K I * 2 0 0 2 * * * * * lens-3.10/images/0000755000000000000000000000000012226700613012030 5ustar0000000000000000lens-3.10/images/Hierarchy.png0000644000000000000000000077431612226700613014476 0ustar0000000000000000PNG  IHDR78ĔIDATx[W?fyg띉'3f2IE'3c( (n*,*4 4{N-Musٵ>|>U؊Yq3^Lp[VځqQrz ````````G/ @ @([܉&or00000000r00000000(gY|Z|```````` ʁshkIwϕ[l?Lyiyt_Nĥu0`Њ;:\@/Vio<;5O"t=c],~3TBw[a< Dx1+4FQB|~@K[>w8pѠlx0?Q7-z]?&xݡ98EO˝3r#Lg;4q)U]V(O;0Ǯ{ksFVCoSg|ڵ(O\.{X)O04x p~\k,8 Z1unB7?#{O'kf9t>[cn=kJ&DkeY"ߡYuξFsvc"{P{o1h2-6~pm>wp탮{z@r pD9c oǂ5|eDɠ+ fs-Aض ~EoErg q^_c4uŶ[1K?~WQ\kig-nL,_OklphA7voDyJƇ & L Z +aT5 W$j-ZloKo{T\+-IN|M{j1-eE\ТyMzfo|*7_7bg f|FZ%4D9nyS\7\DaXD9rJ-1[΂mJ /g6 vH)Gl-#قo,( \lE5WUG/=[\8Qea磘CE+7Y '[J R([; _`R7z"gx|ef5"jT;_7|۳e]3ݟ=+C> !^>?N"r{櫞 gsOKgdO,⹮q1bf F w6yg]^t|ZnfapSlr;(^V\3]%Dyawǻy>S{9`i`y L ŪX=\32cql̨-3:1}fNhK 5".K(۬y`< (x-}ww':f'L6M=޿g6y{eQ=>e6d>ovW˚=Ebuz+.٦WM^ݤ/܅MOG1^SϦmNOf댚*_bjf,~3 g~G):6Y\QME$hD|wqכn;YcP{m'f~-yjz[6T6w_oG D.F'x,M/ݣ& L @ Dl ~7pwW:!V7Qr[v%ѿKe@2Hu8B},oCs_HQh lgE{o~ճy*.]Xi"7y33gg<0zܱԛ,O>@]zLYfo#ߤuc-"𻄻K3vDY L ց(V"rrpݙϑ{m ?ĝg&#ЧT@F3oBUCF <^_;G&J1ݕMrψJ麰|VTz1ӻ^ȳ캰=a1,6]I:5dZ/M/~<_Fb79be։\Ң\gusd;UNzq{ɺ5;Jڮ<_ѣNO~QW>1 Iڿl)`+6Q0 r:.?xkV]˚EyJh֩tD-Hyl(f扏8wiz#K4cB&ȓ_<%UoT~zq|Vʼ %]cXo@]Pe.W0,?6E넸!%`l`R XxQn8egX>~U}uĝ.#%NZ[HF3t[of[^,_t6dQ哭z7hƍө1;OrI8.}(k3|r1}n.zoJv*R4gt{7;qCSΦGmZMDITg0f60)Q([^nTNB`fzբj'-ʳΞ(?ժwU"!gssySt* qN0'ڦoyWUW#ŧ.'ycd>&GΩP5g?2z"\f/ԓݾr쥟o?U6 jޅM.\4J&s˩0Y L @ ַ(/7·Z26BcWӉg3:Mh8|v;ɟZ5 ΃%m=egb%no$_%s^,:F3|zϧu5#?cQboyU\[ŭwM^]N:8OUg9l够ztV]# _gJ܋g0f``RD=pQtvdXb ɮ8Cj13|՛$ڀbXD/mn\VN[<6`5_V`<^`+6Q0 ~I`+6Q[<`ru6qW [k\p[M L ֌&oĐ;;uflTx9qw#aWfӺ=xW\7eS>fN\y̚ ѼMOV^ɸ'z.l`|wyx/؊M4&X]E,5nk|'T++#6aQ) އg]"ۥTfϫ>v՝98IhlDJ?YRܒNϿ8U3T|^&ydU]r%۱(7 ([Ӣ6(\;6KG0D"=[wݞkW!aįl#*"guk4Fy\]L[3mEow/LG>!t:V;;8nvE?Ѷ }!i"? e7Zɔ^EwGo%ls':Hv]7)=Z/p_Qo:'sӧ|;r]9M/N'wO-Jt cE;=:|Qtr}7igU:Sq$jC>߄zQ<=)Ȉz{HTp3_ʦ3yS{P1U؂ڢh*"xqgBUgQTB~q7bh D9/q F"cHmvJޟV]#Yg5!2dg 54*1tmp=zA$qh5\c.$6%$S~j=wt/Hϳ =D@yf$ YO\#5KOԑc; ̈́~2I+re4\R t̘AW> u]t tv#֋GKԗH`>yD\E9^+}Au@` L ^ Qn6*]g$/~c^f D`"X˚l\"h+-ndKڊi\uE%^Z~q>^rX;4k6 &y mezupu:ؤQfwD\Qң_$X"?>KNgm?k =Ĉ)\'/sm 18͍XS+u4>-y 5 N?B/Iy^QN@ A ([[k Mޢ!& :χӼF"Zyo^ѹFӫrPEHKً0*\SPn2*NI' vf>:)swd6ܭ#_ka۽ :z(xڞD,(r%j<%7/׏7#Jw>xBZc Y N=oH%V6j{tHX<ͮ{X{y2iQ3KVqs\_@n,Xl& hB_`R.D3fxhWٜ&!RbB'WJ=#ǩldg^-=!:SN wW{Bm+ʉ %V41;Ou2"Styhxr ߫wM9=CL'++"cs66y]N,Nԑc;~!W§[qu`{'җm>篒\!^"\9?ׅhv=l8<g7\17~6[:P~,?c?Λ0蝷$ʍo_n ~I:4 ̱1߮ǜΚ&O>Rq¥!Tb":\7GhYӆ6;K7}suG:?*1@r|Xmx+U0m8XqG!4h߸Љ3Vq{{E0;32o8_%(N$6^"^f b; _`RrqS5n[|Lcv*f"1tN/iG0tYN|qvReqӽDd8X }S#͒P+[ I]͊ǴSf܅ i,'q$lMrwXk b93℄YAADOuo$g岷QQkqK4*G^~Gn'A(o ̯Sg&:+6kDa\U(@˜3_`RQQ^ہӮR[Z*a2L Zh/؞ \aužp[J/0)Qh8ݔ.7#s\'՞!pH[gKϔ[zVCgdyظ,_e^ -y&{n<7W_Szo|_Մ+9~A#5mċLvzf33B*`ϋGOO-_ AW82N7lZq{ (T};KjT KN|^)Sbn_7k|%OYy&o,trDDZH磵Jϸ!t$ٍz,;k )kNķ,_G@|J _`Rbr5ޱDtryG?&=:2뤢y<>}^PX2O|׼tIi ,jvMGjQ~mJz~P4Q֧}{?jՎH\FfW\?;DK!_شҧb;z6;˥>;iWǝyY?_{f)ztTYCLdm5G*JAW{<(O:ũGSư¯1㨗3)[뜉O6˳s?٩"o'F޷YSGp+\d}a :QfίNͿB;QTx-DߕvtxOfe;;BG@(@`Ec\_9A A57}d'aw_ѣ6;EQ6(쓄X;P"pu6Nqj/D~g%(]uu*?]#'~Ğ[2;/;Ri>_o+sZ}iJɾ%D5U\ъhrݮ;Xk U2v;R*aޠh궯_nu*y }} zoKn=_i:h: Cޒ}yb.T{ț I&5Ax[M#]4^x]N۝f^d 'qcCk ;NjαD9s(F L ^QN>_72LS4$#q1i:<(? ;hE6,vwh4ο%;kuDd)X[rDyt],h~QyH:VcIvVsZ[uAڟ?2h\27+>yGpÔQ`UϰۏZ!!n$Dn0B: &,BڧabKIUVφ`u0* L ^ QN/]$DD4U_<7jgPgb1ꆣ",/##:(z"ZJ,5F-mUpY YKDQ, G[Šrz \-hTHc'E( ʓeL4Q|X~ϢQRyb1ݕV_ _ ^~Xy0DثpQ.Nt"r \e4rYH9QEJGƝXdB>!~׿Q` /(FcN b ( VB7 Y.\%Zg { 6BdCZJD]wޝU;B$WHjZA>w\tZ$l2ߦY:dYLƥ\[JFGlDF57PdEkcPmDDvԡT udNmcц)f}ZvRii>j/ݎ&:*}KfVB6{,}n )7F?j;{{m/WLXjlS+)9#%ĊZ?1ET;ojyÍALwYL9ye4;>i* WaWp+ g9 Nkp[B3%/0)xD9$ KS 8M(Lka3FRlc-*MV_qsoNue ˔_%^4XpM!tm `ph. \..dnQ7 ǖ: M|)Baap\/Xf݌>ۜ=ؙ08n\ieO+jgIe/k'E9"4Zlk8rξBQK˶Ɂ+_ ;˺cT=Wgp>^t/)Q#S&kZk@D1[juM" Qm%4/0)xDy8N%x7N-:(&&@#r~|fYy8E 7 wZj5.2ˮ#([`R/pËfVoX|o.>f7N >֎ؗ^csgtTRYS`V X  D9/r`RQ' XD9l=ɩA`r0r0Zc^, r|;_`R{ `+6QMx%ϕo.yP/ʻ,~60)Q< r\?/*9q~N+7*CBP.2/L:~xQ<tB!~a9^qm\Jv󶈓v|_Ge*mkrUH68WIO'bΚ~c/ Sn2"}`],_7/p[Mni,<],~nF];~.̘M7㼎`l-=zU\m0KL|oƛ\rKJ:%N 徔ů9{lK*[1.QVF?wx-O"~9^1clokFx?#1QXύ^c5"u;eB+'ގF&49yohxk\e;? _G$T#U=u Q{yD`媔¿^Lj$;}H/[{pI;kpd<޿_TP㎳+cjQ_scA q g9naCc;H1wɕY5* 5 1M扚vwG2:xp^pNa͖(r?bQ[W{3{t%U+P{f7R r:ǖUvHb/K{\p4`RQEM@N"Ծ!GwO@KjFaϐUr\C 99\;Dc޺: :JR(|]˨ǓSv:ֶ.Ũ_&qu#d@3'(+ t}O *6|x(_)#jKHh?({튒yI."a~DQr[m],5QV?Hm6Q9x.?n1$1ר\R`e'/cx._hqY۰xOӊ}M! n[x~Vf- NqR<]#y|?o ?wKN9Lyri0r?R y_OO<%_ v4 ЫSȻo./a,՘<Ƶrm2*sVb"rn 'LFzqa p\o/!Np+a]#X{Qø=Oe2 #S ic9'_tD>e|BbWܾV2*zM"\3%`US8XHڳO9&8}OzD6 }Su5-!ɮ.M ew2@xY?g& ʟ'/E/g9鿇̖I yޘ>ƒ߸_w_?u0&|0F#87oV8R~wr@1UA撼!zNn谿lLWx/#wQ :6#jom=ssT^!*Cw'FrRҫDm)1RlKW;!oBC (D>ABqö2p?DQwM)(t:/:x ,JӇwrHܤo} [/x23yq?kY~#F#~ea~$㯫gPXc().?(oE6:׷ `d!6RzOS(\RphW{0^ـIgMFcNդˈw&\+瓇X6ܲpnKN=p|rgN1IG5Ⅴ{ND99q 2|Ca>G~.$_=+r-W孶!ԇ1?P,++BSi˨% XX4N&rM_"y'D93Q{xlo1=4c.@gẑ>HcBҏ'Z ) ɸ~p~'0#!/@ w.J&rWF֭ S'щ3)w&nϜBNAyv}!Z?ʜHwUcs]fq]qI(w/:]ȯRb64qW nqd.oƈ~P9G2I&,zGU%лJT2$*ĤAo'巉gO<)wdm-.wO@ynP2v>ￔ+~FvxrT?mq3͍/phNBf#a;yMJ/ʹ1 e9= QnD>ҏխ:4.i39}xc_ԎBh2\ Dԩeo>93?)u#\ N:9)tX@%R3'دDeDyP.%wdnؓ,ǫq5W.H)rܘ)z2jQ=wec6rawBFÙKO&57'nbusј"4-YFp8 GfNT8Yb {~Z~{إpI \VNI]嘆>ߙ&q|x q3]|ɰGb2K?n4wؖ*P.BlT XXd]+ɺ9&ŇѤUDAN2^V~ŧHzwDlWJF&X-ͭK>8pQ<_u $78crݷh_1n/)PvѾ) Gp,<<|v<q!KA/'OM4wѸ .7d_&7[Eݥ巛.vƟe)o-q_P:Fޜ+8g+D,e?Gq`=r!-;ڝ}w5oT\8W5`qe4g!wAnl7K*Oĸ??uy]o ]ɐ#6z; mxۻF΀c/mWҪS]7Vm`B' w.ω^wԋWJWiܬQo KXX Oy HF|CeLj\L?6&{RFR̪3\ya_/5u67qYorYm<[+>}XШTfNt.uΤߓx{GPrƓ(PF7<[b6#>U[rB?9b6S—䍘W2saӱr3*YO b_}@HMF{D~as./Hrpt3{Do0f#ԭ} Sޜ;e$hy#y,W r+!` !VO1,i^ț/oo5UW0iT.'`1i~ܧǑi'̆>vyyJTw9R|L`#Udž TGjOh,z <ڂ6z݄Ql"o`5lQz$pC"8ZSY j?krҩu>7ղ4@(/ Mc^^4:D]tTpԱziSo[+pLBՈGtL7 /XCc1jj-fN4̓vb=xH) .9Q߰vHPu\XcO#KwmXDX%1)1(7fsd A$3MKAk2p 1e5%̻O+Lߖ?Z|&mbz(Dt_q;C\;lng_Wa67z1Ǘgo6ՋVdVm ;%>y(8I HIi:2<.ֆ ӯVÍ_e=8n.43D\Pk Jl'Uz$&O JAlD4/*R5Z!r+Ϋ./l?\|||xFR̐B};Wm jJTT6@Z9Z|{X!"i}VcOY-psq0RcB|-W+ ,AK$z/Qa7jBVwXh4%Ɉ5-dljVKr:,[PQW=hp˄WCǬ3=l#VKfjôL|po+"#ʎ#AWQe-%CD cQ&Iq-87ZjQGʯ)t?W+*BJmmml꒛&s8zUCG2be'h<(Q_)`˾j}47 yzĬTk7XjWʮ[(Js7/! ʑa>Z' 7*8:vf=_YsJ.Gu+l)ѦOK|#C-w>W]m>}oSGZf_z 1s%JC݃ 7Z=,t=bS\;#VOY3CoςQ͋W TzbBVt^P"\ዞr3)w˪?o:$w錣>ȫȾk4YVC~vHQNnWcQ~ߋ;.CK9%Pd48@~%V'|\4ۋy3LmYh.ƾZn{ )k` /(ª›L".h>KX\fIz𑷗¤Z{ݜ/ͨuCDYY]"\BFADT=C:y|saI 4>Tݴ#"}Sćmz#s9_RJ"Gtjʯb fR\J rjsslwᗕ1nrR/Kfzu+($t͌'x{Fy%_rEaEʣI˷2NKl}|/O$''u=/0YQZ$}AY?4*BП7@#:kTZڮ0bS6,KhG$GQuNt̠74Bb#!WGuYrߪS&;QVFuU)oi%rjcҶp Dwd~%#xxFY@wnVAۥgW:Es M{Xπg8ĥK+?.q;B+:~Bobo$>mw z=[NV!en&a~骯zO> ۏA VZ;i~J͆eppͳbetTS?#D ΁/s%xZ3%Гo|`S.xkt} ^-wI L6S(R x5D9_Z&uC_֬TYj*D+*h=;bwd v@2+#onV-'s;ty+%ͅ T#@r~g[ ˜=A›zo÷44xrOpW&eyw_/(?M ꟣s [}>R7@Dy8_nEOtѦ'3 dY;5yQ*::h%EqP?xi4tzhQm_8LQ|X߁wc?#;?\7v"}7c$W4 6!_}{2RB^+xr%|}%'ݶשoܓqP0$V ^Q([㢜 }?cw`3Kq੎N'vtwl$vn;9M-}/rCjchQ?qY ;?8}l8oz H=n"DHտ{!;GJjڊHm6% j|SGuwÏEG4X0_fOQNRlS${;3l4xĻW2LǷ3>d n@lSX@A4x|E߱=ߋ|Bǿ^qEæ⛃]nFDu&;'n|#X9$1AUuG,'WT4mR^j~ʤHhsv TzARA+YU,E <|ϩNRbX4.#8P\W|ڙgK<^G_m}s$JɝWz7 ՟/:9ԣ캀QB܀&p \('a2*-W>z|ddt%!j)I멨Prg.7ѾM_,ʱl;R|Y.}D/whH1Ǽa D/቏a1}IAD,BcAuX:`Q6Hd78pa;_bvc-q~g%],ʿEe'ի)={>+ XG5_>U8noo@iJ )Q g-{8|Z#bX(T~pߐ?eZb5Eߓ*3]QO7lἉ#5:7/yEܰqG`<û$۽X`}aOwK֟]fĺ EkjvD5VzG+g`U( h ^y%1&Ǩ5pN If``E1FFXQ\BǐD"uwg>ZτKW^ڻ?smdqtˏS,IC {UZaEOQ ,(?Po_o7.l#[Ocפrㆌt1qSO@[# b|(!/_cenE٢u F6m~p's#^:"7n])ӏ2wLj{p;.r_k'mUPiϦ5;b:_?=/vb_o*A>Sa4cQӚeTzéa3Lˡ6s8~O\07X>t"Nݕb,rT.We|X}7:, r,>PlDo$_Q@ =5o;+j뇊G|/;u\^M+>,q/ijx*!ճ@'3u ~LF?S-!ڬ" yoHy8_wz fҏ]a~5ӏ ,J`K&nt}ܓg#XECrDWU-5U#l1~}Ɉ竌feA lrE='zC;aմ>R˨L9ܰջzZ p?kJw|{_mV#ϵժ|ц%TxEyT_Uk1HQoHJ wK_+n5bJ@ϔG$GmgG4oR/+8t_'ʥd^Sb"?(_#}r/\3¿:Pkq)/)b?ah9QIyQ(u/Z͹筯~<缿q2hlNmJgP^f='~qZMun̈#_+2.Ҿ,Ghd^ve l,—rK;b'Ȳ#rP+){StA*[yySԸ1k{d?ߘ.@Y)Rw M Jqt1[aQ\ThM7kA @?2G /MG8@`[Ղ7SB~K;Ccv. |nXJ1>;ZDWe? ie|G<3s o~˛k dE"o8}2RNmf_YXzIKʨ絡~,zru;*5۸W~+ς7kƞOt(uƲ}([eQDq]ruz۳m݂Of8Z,' ճ1*BuYlRTMꁋnM-ڏ25XT;hamuunm˾e<:kEpBZYΨFsL@%&j{^K/6 ZΗ%-2hSviscBb])Ґ70Neۮ u1kN zWLv$مhdՙYy̡۝0}^ҭ=mn.9onq-OPyM226+%:q.uׯ.z+"/'ع_TboݢpjMc VLǒ'E |E92;sdi/2#Ef>)_nuHm}YDf^|/k8~";*5xZ?r+iPi@łߢ0kv2yMKQM;f5X.EX3n"n.}tNZ(㴿D*'C fH9M X!٦95)MpM5RF )?L|ys}T?h",; {:['á69SĶ垵G T>Dt7PQG$y%26BC,=$o`K-n'njuR-3i'V} @GHamxAgD9KIC1SQfǛuz)H EWDi:!%} 9eֳ,} ԔuFlWYݫ-_M y}<%"l>M [r!M`e!p>)"`#noֿH~JseNݗw??7x-+ԎWءnn|6]Q?jP-V?L >1H\S7!e7dmzQ]v ǹ- iO? cQ<OzgoCuٓmf>L@Z5U840EɻGmtbb^A|Y]D\EߒsҊEbws:jiwujJUO4(f/~̂RbfYAIc:5B}C#ɵwr y ew=b5,oLu""ln ]U5g(1x+q>$o? mQƀ@%G 2K pTkGJ|OwC} $Q QnLF< `AaTO(&Փ"нA\g,H;IܬB|R7?[5jzR]{f]u҆ږ5iv.zFqLu$Yz/,Îg{cٽwWgvvgFwI' fE0FL*dP$sՑMD9: ~<^Nx].wvʩR'0ڵ2θs6374 bNw\ :~2y;K\۳zIn mٱו ?e4\XtT81E_[8nG:MhKul=KD`u$6iu!WU։1z2Ϗq,< (@ @ 哎2(Ewyހe엟1څ@yLf*Ϯ7)xto`p:pz;sa~]i/Sj{ Zű=' e3-Q9.a9Χ 랺ʓ'Vxmvc_Ċ}BSkOwusM^}Hzת.go~'ї[+QC 8(.CtNros:r]Zuhʟ =]` (a\S fu(}~Cdsf" )HDqx1`\M!|dFm6]k. u &~hlQ"/\;^s,uٖb'm1Pj) Ћ  @/ MW\Fc nExw[bcVJ@  P@ rEowUp;bͣW!|@ @9@9A PP@ r0r(A PB_k.Mm~r_1QQ4j  hm@C?[Ƅ^ $n1=`sԖl,Q[=3jƄirI>Z.eW/:C*/]^í\Tc 8NeeGN8ẃ}bH_ub}'[=c'LCL U_;QkqI2=w>09(yn;c$>VGg~wҋonlzzc5ڒN}˫Sͦ05]< ?o#y|=u 6b0Xnp9]e1@9X =?P>a&RMLnmw/#=EE[{( ]3TC;qwH2$s2й2 SӺA/)˽ӎZ}4y7a5؟?qmwyJ*qi|'3u=|':W?Ǔ x!ލ!Rz߹(87.s>9b'iNki~QkC]ybn6MsPsg̶Y#8][տӑ2ŠH,}ί`Q1G4cxs&uJfeI2 Frc}̶݄ xquA}¯W_YqP|ovRƦ~\[ޡ /JkK?yץaXo>+eAHX"9g``` \)01 y;s*F׋{1&Ôm/VL{F-Z~Q;lT1P|Pvg[S8SOc]G]S-_EeiLNkEnK#ՒG$^}a*}K:x_uZU&t_i1 .c= N<**3Xo86, 'T D/Nn5;Tkh NP/_>k˽!;Tjm{7$_O 5{q)}h̗b7WFhi̶vmc(rs00 ͡esKt3yxDJ Q؞yxXnɣ'=!3PԔ{ʅ':ދ+=b=+KZ星|͚=0nCUH&+d*^nE4b\׈σޙE "mëlMb;a6ܚQLdՒ:F3~3٬ըlDۓ¯B;1 ```OZɬ2x^+9M11Q ^~k]UwᲓjz1Hnrp ۚ9(Gy۫U~REY#(>wyqA)~KVSO[#n6Pi햟HR@l,-Vpb[Od[4~oإI no}],z 9y-xF U^Oz}.^y䒌u[UPn҅cot[u}kiHlRKøecˢ7Ы*r00W OQ $ӂr3hrh W9cJL i_+KKH>+ gA@P2]M;-J%MM[W+KA%Ny{M޶㍉g{פ># OvOZi{O^6򮽓X땑kv H噧ȗ~m,{eJEEH=/[?t߭ IX/Z,\k})/nZ>dmqEgu,}1@/^a(QO1$sH]xeUNWzP5Z&2籨 QNK~tiQZBۧ3Z<cPLd&ϒڮD2T1ƒyÕnC@````C$#(7$ɌWTl1 )CGHy2@ U0({٠Ia˪K$jdb* PP (((@ @9@nHP>E./v/ǖ` Ֆ8X@% Ɯ``O&}O-  |1@~lö?_T: kc{gR]>|"0((%q窆Qقwo=TΚĥҗۆQTZZ(Q g)P/b ({ES QʣK\s.;Gwۭԏw~֨+3C'?_'֞OhRstRȿMYT~_jmf1>HsP>H#`OAyJݚzPC CE}}Yws7Pzm#aޙS\+]O}ëå)fb2?,&χ\[h/uL<;}jR~F<{j=eWF N_{ozʤ vײAN5(jܪ &0{FRZ9=dxN`ݴ#[˿1\' x2xRDlhnfeFpǚ.Uc9> X ?p3AU1& ` #0MdRv <3IZ[-'LU5˭N sΆf;XQb@zW p6RF)| eaS#{9كlj(Loƥeݽf _$MUsPn*MKy=k3wlRֲ6H pTD>G_O{tmno-(.wt^SvɱP7.F FQ( ;/v IC0%pOO8T#tza@\6ڼ{öiڜG"tlVSe[|TP8Mk 6\L:BYZA&V}{u<9lomap+?# pMOf{UjsNu{楤 qS[kGva'Paxoyg}un+-s഻Pcc00 00x^"(5ܶmԦHi\xpu;P@h+ǔ=.rj8朇…<(g- W ඗[m$]eP>k:leM hK0y>. ^x\D&Rq'%AkeVօ>"X{ph8۫Ic BT&k $@Lon()6. ,)qtZVa5t^4k2SN&^WhP;WI눽ߘ~G-P^٬pc/c ` #0- 0H"[󘩶ٞ~{R 0C+:CDLeJ«/ +rk.OwN..0ݘi~8_l ֯6>!kR 5V:j0szt]9U3h '?hyPjx.f@4IM|xoj7\.z@ 8````/(u0;)RARm?OL6j6LBtޖ<1 $-Z?%gWSP^e-W)1Nʫc?ol5[(}Gr=>1L*v<@i8Ea$P_y$$+*ըRFd[53׹pדF2?p_2\y1k,o쿧򘢥5PzO}:*+>wm0PPnjGȵ"IրWSOe2T3n]nדwx,~cGeͷ "/rʊPJ|JP/<.Srr(Yo,%],V|a%K`7j(dB<^Z &r0Wa @/O- mtؖ:@l/b˱, 'GrӠøk=~{Ly[ׯ@t)"#]:?8xmr+1n{#_\ d9 $@Jű_dWcqUޝ5CVQs_;{bd6|[ƌw:\cN$ hqvF )hP+7}=~5eh~4A``1M>@ @9RåAK 6jV~07ʵ.ھ<-cFq̨i5ONvvQ4WEej{P!툡X=}we_ @9@y$(@ѳrb8D d,@ @9@JCFʍX%}EɃRl-5-6&r00r8@ K ({1|@+#r@ KS)~Qyl8QczaLX@'@9ث^4p@ ЊAWѶw.(305ϏU`I)Wg҆o>hZm؂+|wD|L|oW]99OXyAA``ϑO^Ch<n/i˂yGXq'rNBA/ cP[fAY#|88"kXB^"$N:G7pN$;ko<-OnVGQzW}7U7h E67vym =KŔ)oxPӔW_ZpVp},ƠA``0p-{JY(Ep8Q"־Kl}cʏ9AQ5=/,ؖ28ԫ yQLoBБ4L; ʯ寭$X( W95t?s@g'>X@lH.dW[.ՁDGuP6-ۓp'|1Ԛ:Wz#•K̓#O:SMV&jvOpݵ"_imcO:3M\2m_9}qSN9A9ܦMlk1u _&S\qNMĘ.jOY+ևнw9/O?0 r00rrгMw.xuit>\ ·N>czDBagI?1Y ڇ~LaE~7 )]4d._1w 7F m&-:UBt4.;OL-|0b5WkպUuPJoR^s!u$ӆȪ>Gvt C?AMdv;nm*þok= Nj5Gj?'||m]/8q2:=>oG9SfCAlvڼMr'7>5Qv3 0<)]:d4(u?􂡳Cy_FufMeܥWƿeX?})K<9Kð jb+6S_.1L/r00h]2RXޣdyTU40,F=: TGf,o112a@֞R^2MwE ?Sc<)?^zSNIg@+g咺Js2dT^*`}Lvֹ(ˇE@9T*&N Cy2^ς5 +qJ udl[Za] t) kֻpiZ֙|s?T:_+1uJven3:~Hh0!D@̀-3We԰N:R_*,~|>˝(h6dA]k!d$@na.rgϝ%L_.~ &|h%/_Fc7I4Ho"U_1_.#(((=(Tbaoq =`OhcΜ|~Ĕ[Q8(1ْ[M0YTڙzC9Yr[Pz4l܈{M wf-!>4/pvU]W#@y8ڨn/uCӶraێ9# M)ߨ}l2Zv=Fu]fzumL*_:K ƆY&`a攌>r&kn1y`l> =e0S _RB} iSԅT{2i<~C~ϻN0Yb /;9 -%̀O9t9mOk#Y '0mɶ$dv/90:ϔۑ=>4Xs=?7CK̺?xןBVR4"I-R^:cRmԩE/ï;6c/D&Nt챸C"Y/a;k45P D^i4d[Ye M+/_kglqw~'e-3Ȋn#< ?Ge-~Ҿ{NMibn{hO$XyGo֚X(gcQ]C4u2I{*}.*\0e!k~6]zkg&X|m-$k {;iߌ:E>?~B,c E@9@9 A`֑BzK!9/^ˇrt cpP>tN˻{fJTު|nK_xa{̰s$!ErcRM:Yk.zA n?š8rY5b&8QpR̫T)EEG:1FuĮ=Գ|_vȄEM⠶1][-ZLYM=I7ZboW^KuhMOOVXZ]R 6ڿ/K2j 4ѦI8j$qPmՍk/'pw zGrN/g< P?0,io _җv.^~I YRMef~_,:]<ڒk;2.Z\ڇ~Mr~&}xiU@9@9 AA׆eu ' f}d߬'!\ɥY'νS|K+ۥ3هw*l+#gp7^:([(n^Q@cP؎9@.:$1n?=k}C^i dX~᷼]0%?&VbSu;w&M Fv{jGl~Yy^=H>q|aܚz#1 OːF ac8_#@~}@"D^YY[צ>ڄ5A#t囲;S!_ԴvO-t LnSӳr&FX]ʞ| (((@ʧ4J|KH-&B$֞//*L``0p@A PB@$VF :4x@ %r00r8@ Ћj\({š| A 2(@ @9@y4(@ @`` C8@ hEPnG8T((@ hM@K``8A#VF ((_'+@  JA PPm@+7eTYSn q/R_YUT$VJ;f=^&(7*/.^;)oϊgacVH ʟ &| Z=(@ @9 h@rC @ r  <:;}0~/I{ܨ-%W>*C@/^q(wLxk{%a .ݤ ҙ;|wn>6֒^^Lz?$> iXbc㠮g|EږYA8w"VIb.f}h]z"*P(/U2(@ @9@CSBk)1Zp|#U<@O/RyB__vO4,Cd ,IAs=̵z勋ϛyOˌ~ |6WjOx$Hi|;>u±Dj1o h"TҝN>+64@ K%r00oVOwg;F|jw]a RƜ6=)*gqbJh7$sG!pׯA>1Sop=8®>i; =;1вLפ}.Qz'P(_ sOr+P;c=93IyӜqhg=7(dC޼i·/2Za<~eYƙ> =}N[>_(R@.Ӎr  M=.tԯk=>>(2x Oh3`+aS{Jw0x+s.M4M#{'1/ϑk1|xOk/h ԯ8e׉/uOô=$ԃҪVa}^ax'kSC~cOt.(~cKNԛ1W= x]4Pmza?~(r^5y?g[2rǹl\\!OMa_X@hOtn{@=dk!~RFM) 4t7I[H/~ux}TcU_>ϭ- qtiim$e$;"#z>ik\o#O0arkOKW߁ 4UgӬ>,Xfif}է~y>JR~d{q]]#tvǪb}l.>5}絯nz lzA~p@_rcMZכZEcT{zGb=>Y95޸h]OME 6(76<-ʣ,J`ItSVn3{}s Tan4'4JgZ>3514'1 /}꒟}7yib}W亮ｪn3wy`!r&^$b|8Lw5 ǡ?؉U?^TxrO0yPkQ>[} 랆= ޾14<5Z| ЫUt3t+|9~țV(UN=çVF'f@t)pg6hG|*P.m)W>:2O3t SM@ 48$J{ o7ޑzZ*@ifETGI"]bXD<(\hy7u Ο]l+5FmLXY<>Zʍ>c= OQI;2CKnS`\b  er`I``=Jw@&u97-gV/fzPWJ蓷|.#'|(W2~40-VÁe2T ح#9]jDؕ7+Ojl嵟LE<~34 &~;j&>FP>(߂0q֖o ̀ Vf_z9ye!FWUԽ3 226 `I4 kȪ׾J;w,O/2Os%R)[.?0pWy^οΖ%7kwp>_afv $t_.Ay)[wt7]>-7^roqhE! sbB:bЕv ôɝrIBCƮ#Lu'g ֗ynƯK #A 䯌S&][}n:B;qӟv KU*Ԋp}~ʢcAu3ߏy0iT{VDSq=YluΌpvw)#\Xwcn_`2XC  Ñ m+F wbcݮ;yT_wVnCLnK Ëy f!.P"B;dnܦBCu;C]jϔ1jYre\ݒt$?..oi yUlS |w<:k'k~,56_@]L3&rw6b(_((MaPs JyBǭLM/Ԩ}q\k@P~Uek \mU`L߈V zpl.ofΥYd>ik)NʢI-!פr|\yԆahG҉! Z CT6{}^٤C*E]=[v_] Wo}-*|\~1v|͈$ȷrڕe#p֛ce? eWqmXͺm(=keuXJktg),JOڵ:lϬȿxL&KƔ5d{j4"O QyV_9k϶WCdctnU@%䋌]j{tF?N'ΞmGճ&6LLlV6~F9-ck5x=KT'OAi8xGH1'e5X* YCdkgV銎 Yb8Sa pSt!Ƀ\w"|[,_4/ ]6@ÔvwWa0#xVVvyw h 轱fZ3sK[mܟ\RfӺEBesgߚϓ,ʟ&R#>87SS,.]L߄t_۳gtCм2FOPoԏ*G ~sC/1Oq,rXX_x>v'/2*@yo ^K+sB ^%GCA|HWW7%S1 qi2䠼AoM(4zW|t_ dz]kq^N`KW捤}Ck:0,{d-̻{w(GBX'WL:7wZb5Nv!0P>K.Yf~:f  =gVNOu%҇kdR}gJ>΂&yG8{h00}C.Kv?Y{z"o{v㡡4߰>[FpʅZs #1tgnB(tqϩB$ ܭ?ϫB_<9P?ޯ؇kAZ Le? ~d$yzd 8nc2 MfЍ˙KG-L>v*{(Oq>,d|}n"*8.Ace]Ο@lbmCйx!?^ 0ֳX>m è=wK,(kesڌT9[.<Đ;Ǎu fC 4E[~E)C6v 0󱍱\Do w}N}dWS{bpz' znw"V+' W6R9}sی:8JG>L\/ OKXpÃdl5~ڒ7L ? sh a]]FE;o%U(o90ƵVC9d̜w~:n52XpejܫH>8YVCoxA'7Byj5_JV_r]^6O[݆svč!i>'n¯de[$KMt-j!ؑ1Y:;)-S+̽pޕa Bcx+)0sK*v +BV'I9XL&y~ I1>fr!{(OmfE>uۦ?JTn|i_n7lj4E WŦ68/ ɃWs1PCZ]1P۲_Y0go#Խ[{'x;o -5 QԭUz:Ԋ UiieCm`cP_jRF/tky)BCB9^qfx:WbA*Ku؏<:dE(rEڳe1 ݘFiՏ&kׅ1~erNSZThThU-JUuS=V։#=I7 |rzYbPpޯ2m8o:g=zmA}^OڧUz[1C}X*ȷyPPgӓ8WS]NL6@JB}RMJi@.I)'d*DWK̓U۝HUfX7h/ )yPr՜o߰+%⑻{/WQPүϷ%]3ǐxDGZpX!Ȣ4ə/kbV)'H[*j'?\_ﺭiR2_9f6ְp`n(!}a|T(IV4 7OfXq_H1̽هQRZCx]v%MO!%nJ c)|}1Zxב2 % $^s%yo;wk> _Ǥ{;R\}^qPC A)So=win6E.#вC ࢉbvU;|ct'EV+XʮϿh B]3H}x/(ZhGzp6`sG`;N:>WiH C߶Uh:T2~yɯkEoz]R8(MOK~mO?Hŀssզr{҅婯ht8<{Iv?i7w#b\VȷI``8N@ heLl-e#kQ)IőDHZRԸTLŭW1"SQav1,s"}A8S`O=M~ 8I+__KM,t/< J MOJ&e s@9@9@9G_-vuu9QS_Ags[w6<[?ƥl[  ^U(NJbUwK"̤YLT[֬k/Wy "9qL;`nǸ<-^q(@ h\o zPC9VF͊)r@ 3Pqrq{ H?.zċŒ08&m\(XR20} x.`0VF=lx=ϐxs\gT0((> A#VF TqE ZJWSO淾sg;C|¿ŝ74![ŪNv($u ' wKzy6I3&޾n0+}-_efz"8]t⺓>rpl`y(wӓNpVY)NLھ5_VIwl|8+f`# M (RǕ O"eVo%z(;F_i5JoQ;y$zU5X\{Lryo^bLy V m)-CΥ+FlJiF-*M} 2_?Qgvo $+h꼋WbM[_"ǫe֥/8zغꃂۅ9 KUܞhl =&Wf `P]_M48M.*TkȉD F9=Vh3)ʖA0;W7_ߝNs|.-6UWv(o9sD/Gs~bW{ .QfTt!;%0n$ݪMW|)yfPT= ŬBg7QY8^Rr} _>ndf6׾>$)+>G_x :/$@UAW+FH̪ofO[°ΗH'狵P]-SPv b_gsJ̒zɈ8͑1<kWqt ߣq!zX |jknq;4S8dR|=` Vѿ]?T*>/bׇۇ_I ̳XZ^u(wcT .l=GO#ӵ?6V % 0?l_dԸk Kk6ԏٞTw$Yy,[ fӸ>IAwSJfS=_zMF 6)egzʳjM,4"u1 6_o]N+Ub|qG]+uy.)IˠC(Yc@pg'NWp}'R y~{UgکƠ-fH~k`Zsz2P>-G:iELkB EZ_;OlLxH; -뼶5b+2'čWZ]jCn ,Q/= >w<ϫoچ.?G'n㡦kYS:v_=抚&#uj\;5;Qm ~YF%L#X۔Y oL=f'^9C/]+yzPy])R\rZYyZNLA ,O/XGC8pc&Mxeˇ ('emuLjZ`*tm&!!+d|?3R)KF:%ZtTFWV胠lTtTѬ#إ\ ?r(׏cؘoh27%Mfbfv?0XJyݚ_wt%e#pJ$~'GJHJYUSï\M+V%V(?!N$?Pynv5lU\ _r+чL8Ad ؜wL4<8R܄^:gfoGGf>) r{qYdEY*V/Bˠk<ֺ9z$A:@5K 4]d%ZAnΈ(\wMqz~A٭;+Gk"2SjkZ;$B[S lLPtVѹ^}1IfUFNW|i ӷGiVQe)B4;>.Xʯ9Bg"ix:¤İ|#oϢ&,L cptfӠ ?+?p<92G} ;iV%:u+t!T}IS>巢@޹5u~rwv>muۧOen鶥V 7QAE#&A$O.$Fiwf9vyp|3sN=̠zң؈| / "o6+}^OCG?uLˇٔz%ط>~s3(P Y/ʟ60x~i|AϤAs%j08WOw{,à ?SHޟ`B_lyV{BW$( y@x~sxh}!oxD&lDGO4>} ӞҬn٨g7A(S*>~m|.;vܣs=WbZ,<'rpFSbAkwж%nYSo((Z<v B V((QQ![׮ @t?5ύRWS_px?4{78r\ItNތ=߶f^&NdmFrݿFO6+fpܠ{ 岔Beyӡ5u4ȠG'ޠH8ZA`5Ow_}و+Ϊ BL5ɾ"2by;Eʓ^O@uvxTM pe\["S#=FuNgt\r) sgwr͢y^:,*Fl9+ۣf&.І 1mAg̈Ovb GT=דkRҧXͬo4ޗ] Nk~DऱOB@a,}rO "y˦9 ` x'!xgv/ 7li*@v$/ `ukd1$wt"h[k~l={IqDtbw 룛?u7Wz!0kߔ36vpQƼsGI?^w!n ]t{es16'JW~9 m8h2ލv`g% w"OqRrm%Tfm'jtvwde>˫ur+, 赥gS]a{пI{>3gh]D)qґ3a=Xq؍DgOrkT;5ŕ~?aк~T;gfdC*\F%oJ&5ƿ4гrc{32%' KiK0Ήz&0-3} H}V'Bpu\P?\G}@̴G#0ޯ2?jM1 _ʟE(GGi* si9!T4,Xy4g0;y00u+|CP\4xvZGS ~_^YH2ݡbA8|64AX"l"s(])ŮrAm]zj]Bcu} !Ky燈qUaG3n TlQOcL^Lk ߈uac) I:=sCoP+]mzU8q@3{f]ag岱v @p@6AE)ׇ[٬oϏWA~`liר-n~1d5 x. 2qy]Z'G2_y]w{}eК&*0qhYS .xiɮAΠ-VLN5wvʜ.rUscVNuw &|)|6AlV/^@v`3e}oDHn5"'H8SrnsOyY3.YYYYD2,r_vJd›jC99q+ )?vm~dF kUY_w;F`rӮkǾؼ> nz5ٻo vervUx7f GCM׮V|/z`ׇWWZ:P۬:ۈt4`JzϛaCvjҠO$P]&6OLJB}vgNぬCy2vukc(_zgE0=!l%RƦU6CJ^B>yԶ+u{ąr (7R2 UȌV4u>$P?7%B9 ,X^,P/|a(_5NkqI` w"gnB`fp4вm;#&!34 qҸzuNιE6; d#xJ1A޵ e6ALrs?i&'X֐ɕ釅=wC9p'7v׸Pw,/o"([]^{y<I(}JhIzIxwvqsY<{'Vd_ p55(+3'c B99^_ 5&S i[v=zMtՔ5WGm*/TU:W5Q-uK/I}AˊYrPt #LF1QRe=_3گGحQ3<͋*i&\P/|a(ĭnۆXحg*OݞgDTp&*HB@Й]*Xg!ds' A(gS{8퍱X~(Lv[! m깥b(N80E|v_Ej[qY햛]<*<{?6++բ!k}N~@٣Xlg%~3~ nCG˨ _^rSDlCD/"h?`ڢGu^{DY> M>3ΛR[p<]e2a~;EV [Y/|@xSCY(Fj, I/^/+t-,wmգPH=G%s5+c z|WdW-vtߠzB =/9uz)Z}*XO{37Z20)9Xs|v{Y%xHVgھ{AZ3=*S~tD>IMU 3 ǼxK%Gm,d~^hxkt:krox% xyUÆJY~[joFmS(OϞ)Krr"2Mu[M~:asI-<9ę([ d #v(6߽ ڎMfRgi"r| CCu&:e-u$n/N}>VܮX0'b 54gEC&Pq:\{Usq4nNPQ8bAo} la(5(P fv0aV!Z`<-8!wj4I<2RQa01Ƀ=h`@o%rZ7.X̯B E$ZյbAi1>-7Fʲo !y)چt(qnXm ]J6N:#tdCZiN[#=Oomu,k􍅇-6M :_lF>GuX}#H2p9f6Zeӵg*mg߶g>d"~lFʿL&+r.V>u N="~bHˈ1~%Q}.Zh[b }1 _:1xlFr94 ~2ˏuq l&QdOQ&'D:AαU\)L&|1i*H`,*?y[Ӡ`+n*˘lK@dmae9¬B9BLfPvfy?@9y}:V - %=hoT<. ƴA0w|(6A50x|z)&4=У?b'IBa[#pAsʉ@y=W6xoK=r Ư C>'?J荮ѨX< e`ϭ" bm09h7.(Fds'WD{WBM=ߦxd} >@;*K9wO_{cA E>s)QI^>=Sב,NE\fW?BoDvd`ɠ&Luld=*;SVMeitߣMZECfI,'fAR v^_ciinȗ#|IE XOTYxFrkxeV?cC0>tݲ>JQُm܏к>} ܶGa}m/:qq=:]Wm'B4vAks<` ]MCyϤ k}G\w%)S%3w孡SGL%Щ:5z0[Y_y^Kށ*/X\t4H:'|?5SEGr+ϼƦY5C[ޭ=9Sl?]MxD_&ln_Ȅmy$;?쵀 sjNuᰶ^\t~&2aBlN;byT yfJ.I vT1u!ϯIu4:D9?W5j`A/9_ Zu^x_l(>ލiB/Qr]~k ̱p1]na>n甫e6#o4.}&={/i>wA뛍VpZmw;42*|h'{2sHg3'=M]P/|a(_6(;5L CB;/\qpG|i4%a~6&=zK%Xen`6.zps|GZנNN M4|huGԹ޾Ձh<@/ CGIs(H8"b㐛jq ;Q4@Q 8t Zf>Ra=C6},tkPXspy>F-4ǃz/ڝԏ's,:;6m}kQ2C6I/d6X00زcTKS1# ދ#f?'C93i'Qx? f\d}ɤ,f[qOMOED`0)Pg6Klcw!Y,ĞK$ hzGx2(4E C9Sh. q=т=;!a(7+rL<30ek K{ E@L4w s[CtP}ސH'ͱ]Q号q~Wx^MA}u{A}X]7*\0۩!os0J_󳷣wa~ov\hxsH{'rIxxʡ=N9czB D ބM$Q@7)!XZ3~ !/>ϫpƟCRmN_ȸm`(gr{LIk V", Me9E ],ˀV,,/p.b(0u|`O)c#v횮z3^sof 7>NZ 66=A O{o7?4F;k?>~{$4+>;נ1!o+kIo"G?Z4ډx:G'uM[;]0ohnu^-&ͳXb1;=}:gD?.ƵL:t;{uB} oM^ɻuȤ[<3AP,Kv6ർD6zxmz@G6S噈=!5㽤AA㓭Z1iRmN_ȸmwZ%+vrYXf_PX(30Z(@:gw&Pm2γ (i:ѱ\Ņrs^k9218n5߶:\aKCBja82yO8}C3B:B9ZkzҎ Yoz߾Lu!'[CI?dj)8^SK&<ה_!IaSM{FT#H[jݝg4qzO3i^FY#I:vY&㉠|6I/d6X0c J0 _෼mUNm1ɴ)ۿJ߷ɧY4>mDr4'6gšy7uWG5]ww~aԺ8P>f N#/a/|*{zԗ)0 /u2Q -Luz&b_$k0x޻~FQdrɒN_Ȱm`(ǂ ,/|=GPn -Nf4~@6[ 5y^hYƍđ [.b(0'6,X`y-q(OǞKOt]ݚ9 *N53L-nIk㽠au8;{]gm6Ϧ뻥b(6&>q1T,UN]"r| CyuA#,X`Yy*PNJep0y|"<*p|Jr` lUҁ);@ߐ],aBPqG߻RUhQDm>%{7Mkc[.-G!n.=V&'uM9G?-ʕ"D/pl2(` 0N%ZLZ`P=,p]ZP^jDI]hyB,E Y[ﺪ<ptr"IjWMw =bڛ?l> tEvE ][^T}2H Te>j2uّFd5(eᏵ uz9cm7=-K6ubBHNVkVnN먎} (O)_/eHІ!3rĠ.F6J0V0GbAzj;mޖzlw z*n)ډ3Og=0 Z FM|oɰ0)6E]WGNh9}3"zQ>=n:_{ )7ޕhIKDkx>\vm^k7CKA  tG<]{/Y>Q;'F]ESA_@2 ?9'Q w*[PѨ DGAYdPh l}6/RU4K5hGeinȗ.۝]P/|a(*P~Mn}`(N墋'vvԍ][53{[us'ao)T"֚!^>ơ1fP$܅fAyzZw.+T ~u<'L;a=L%bhJ(7X?G*wOXDOVZV_fi݁ǻlîuc(ǂFţ!!/]_ fV'{E06'72';yWuɛ]"fJM%1GKQ5@9_VRWuxHNӵg*m?oCZ:`܀$DB!*!ʻQZ $*l2/a<حR~ߝ8ͣdbٴE?l} B4NBF`^+ +uG]֝^;cY&j@~Aἧrݶuom}wo @z@=M^+>)i7()Fl׃Rm (sITh},g#ڻֱ;wpB bE7jf'Kt+yitސ:l4 5Y޹;Q^Ayά]Zȶvw]+vúvև1`y~@9Evt W13enH3qnz cCrT&JP}4bޘbM蕲Hh>h > ;aH5|TĹ6no cD딓hbCM˻=8 'xg=f6SpםCM"!|~I J-w^̮ jgP:GrF kS!O4[$b3zgT%'D.㉆a%7巹bλ]r>,ٵ=(%Mg3'q/ Oʭm,n 5;`J K )ѮnǪTڬ>+g/^@}]wܝLJҽR,33o-~R2:g}'=RZ^B י:'w4 :n(n׮G뭧|5#zG=nKL]nڢ)!2,!;筦OƲRfWUH[UMp)Ij X0//HFd PWKd.N 7Q͡~]2g*xUEH0 ^ qSABF^{*_|F'bttNBEPlʿg3-kIUfJiϔ%ʇ~~D;RbB5OgL q"r| Cf!qֳ(@MΞwG 0 APeQ1,p-+RH^ 0Y;c;ʋ#P0Zގ vKl0Ňrfr Y;ؿh|X>0LYv+FLH( {"X?ɆeGL? Vr}r,ʗa)3ޡg-],A喋uLyⰤ=7ZzX\ ,ϟK`Pƾ/ ܜRlj36na~L{Mm"PREfv[6xnp}}n&qMw|^-QxaSGvA 7i }xkcj2Qk yŧ-LQvŧs<3ME嗰2_g`>ȼѺw.(}zېc6꫐im26Y3x7 P65SoAѩ;n~B{h NԀza߹:xAiuo L!ő8)wZ%38&NuQ"u=FeX^쉤*wC9|qPnV0ڠW:_-sOC8:alr{VrMeoh,,iڬm;FpǼ@ -fz#]1ei\;s}1Lăr{!(;'K7d~B\r Mk1;bP@>mF3׊{櫥ǧ@yzsuY$-ni@| .wOXRB? h׃62cĄrr`p8%?Aly%7WϞV)Xk?NҏXǿ}'>hd( ٢Ii?wrb@yƂY X`C9יs{d-Oʷ2Dk8b2!{mU!)tS>Y?'#vOK7ݲxP<,Q&DsįK&Ȼ* l׍k`^Rql5 η^~_ ')b'DeB7򿡙.b(0'ԉr>0a 呧n`e.+b2MA O󯻄F֛G%]?KhP*f<2gT3PrGY/ā2{ Kī-(V眞}g={K @8rY[Oؒz#W\MǛ@/֞$E{P.*r楽"f n?B/tKH~M @('C1t4ϯu];gwy)| d^tc5G&:MUW h>U Yk΅1'%̫Dd>#!MY=T J/ ϕTۊhQ٣x}/X] )?}]~kgbI>g%'->D#~LxOmy_ eqsxQ3}emѣ:+eJֳv3JmϦr64;oJ} 7\#74wC9C9,X`(C?l(ˑ?j1Fz~; zdGaBb ͗ 5; 8#^k%plj, I/HO8:kST5)CFP/t0Qj m0+ٕb y2(DmޫPB; OAk<$b`bue]@9 .Sk}U^tL^Sq;6*&DKl3 lF D.0_ܑ(HZv?n it@UɰXL'd5ETW]7΀nxy/Fy)Юvʽ,U *AfƦنzmAM9F<={/I>TQ˹2{ h7-nj4yP\Rg O1}}W\}h-B!ђ?>@ZiϦs\Y;h;vrg7Kɿ / /kL>Hp~Ab4/ʂ B 7k91"K+ܓBB_> 7(ꬁ655a(kwr;Q+}-p0,+DKӠ-$&Y )w=h`@o%cPԠU>RBh(N3rcY,Nay !y)=m[# A5=%Qdᤓ sЩ i)"ۇhy5K=:H,ǨgBT [fi"w_ԩb>?w ~%\6aCyD/X7$ǟ3a1mU+PfhL_| Vtx߇SxD|-MW\}H&:$,t}Gĕ #{(uH;&kd}e;m$.Zh[¿qa.b(0Ƨ!DmGm\S*&-ifY\xO7SaeOϔ%sq}4u5G7Q;3-wYVs}|+ |9T֚-3l]aheRm:P4c,< (26Y¡\Ĩdmaeρrz;1Ħ`eJ̟`DKy|Cr.GC"*qm?R h{i3~jgˍ`߯yfEP'@Eb囜gX߁ryٜ~o"i.w?6Kg NŽ_`tw.x7_ƾG7,E : ?a\Lm5],;~QA^s<ԡŔ3mM?e}h~JK2dIEmhʿoZR=I{Yƌu2<-˿aeo/3`l;~S&  .`크5BE7Eެo{E &5"Uf°{Ȁ۷{͋-@EiX&OS :z & "G;@;*K9wO_;ȀȇrN;%]=ëgҵg*:ipyd=:ـd`ɠ&Lulz0j*;SVMei t8V,Y>I}~wLK) {}iE !_:ߏĞ|1 _3sFAEK,KENM+LB6?|ye@rKah2?^Wh =>0Me3auѷ+&^en{=ZѫGuˊ7@ϔ*6_ux;d[0WI#yMwϜ ' L>;"qM薷UK:E {>k6~/擋A)5K^ :ʋC˜=L/sߨgAS&vXWD8fM~FZ;δur\EHIP _-M^1/|My3Ч^kvvA LU>ИpSI zTGRtjv/4rJeMB{!›km@=q4X2%DK]Aۦ{Vÿd=,tP~\I%bkf]#y;fwv ?g8^pI7[( Lh`jAT>(r#vMyh'iߐǶ(tN鐎ɯY͆x#iuNQS?cLϞKmB='%^Pd9轺6/K vWw lC rQ@ѐLMgS,c(6 /  _7a5+HnF5/70n܆̠YhgF>SgaadF zf~9ߛrr_,*{t 6w5ߣLs>C7MoZnG]{]:*Yۛ[lP_,~I˰ .]N ?_QӻR#ḱP=I n0_U_R̂K˄+?j .*rNWmTRd:m>68h_9/ w'[]'v.2 xy]}oiG֚`ȅ}*3v;:|bԎbChIm1_w~v/u;}'/?rO~8l?z|2Rucao:mْL3nrl 7c{8P;^+z8< >BD%fo6Z nkw=_:M+{|Or6\N"qLX#74wC9IAT)Ў5)CÅ3,5X3QT}螗_B0@~?Sso/^fуaM묐>  c`]rP֟du*"˃av%H3 [Mt{c,. P AKAfTCr#{^6mPb *l{pE.gwSluS|(_nc(liڏ2) jK:gqz-N>/dM]լ2 }&~?["6QYxfGBW,~ joR~j2`zKB{< zNyc1 y18l8f\+?H d63:7.noA&ԉ K%:ۙݰ/}gs-YͶc(mz:/" ^N:YbN f!L_|G7<> ,t2N#[3٧%oX&/ 剡| Smpp~^WT3=!I 4h(xtC+ 2릡\~qB3 p3ܦ 7K`iʹϏ$f3~k.$gro:^o:dz㚅{2\p}Wlx7^93y[#?n3c;3-V=<^ߔO#oPQ-PBXұ?{HdT>K}Ǽۻ*^@7-!9m? tJm>pYEЁP'fvxaڋ<`y>iA9 f \zז' gcYNͺbפ?2 U=2 ˋ/oX/ t2?ЧFEYk.X)큞3g~_MLi ֗d*BP>y*r'kAaH~ŧ; Cm@GP炎I3ˊ4qt"5aHDV˻iTVΟWCڥ@H9t:øGO1eR2_3MPoAۦ 1Mz O6_nj( 0LwO!q'iB )ߍȶ~ vg"7cpb-N>}g<@*"ZV1G)elAvј:F?56i$)˯vw|g:nm6 '@Ih/=Srz:8gd"*'L 2S>Wj|ډQgcw"r| C>ZՈoȋHs2(G fA~r" 0  A %'~KJI 6Je$ @9p`ݩM*AA*P 9P(iAkKZ,jQ#_[|BP PtC3F[_̻gJjʦ?_Cet&O+hhAoq 45khHYmuIQ[7FK7&qeik&UMewNv]sfN6dwӰ MdϩI9ɠOO@t'O2P_4{FZ -b3,ʱ`ˋ#/ )WpA" ,  1_L6X>)7l~#YYYi~ZvK>= m%s ,X`(0g(f=㷥iƃ'#r ?걽u0`Oϔ - ʱ`C9 e)cԲ%ikn(.# hmy X`C9@9,X`P ,X0 _1c r,X`_PlB _`1a&9tOc{m32%O< /L46sjϤcla(ǂ ,/ ɡ|&45͎C:i tu,UA׏*{rpqW'kMQ Η`_ Oj/yEe0j$euƬ5!"u]n{ʻob_}Cc7=NGxZ6=XWv<Q]C$fGus=H]3]? X`C9|PnSk@| n\2{'(ZҦpr Qvw,6jlˠ}%Cj˗vI=pDpc6{7t|nyiDԶ73Nglت%R*(" D9'C8BHAkCHB©~_dZ^^{tQ#bZjAU5ig{&JS+(ϯi߭6.+ͿM5͗H.RyW o_iE25K8Uw8i;&}H>o_EV/gu0 ÀrPO;,`gTF͇$| Bn'?-g0z'zp}t=Rl{mH+QYPvg=I㫻׽sAgK]mi}ˆ%}r:4cGP猎p{Nx o.4;t!w{*Tp7-\VXߖ6sx\K.v !R'>$qb㹱 Ajv\2l%n<17vivi>iT_LzmM Zo|@Pʠ-XәaoB&F|՜]eӛrwcy\iB'aPA=\}q=ѸvVUKً7Q=}Kjt9./MgXM<P7Vhj = d iѤviR P((1 0n3=0Pzx`P1zr(o1^M^ e:k6Α\ڷΟ~uϽA}I#Z =F6^n ;_ݡavH'(fgۯ7ٛ!g|, \<+:.?Xؾ5V{NKP']v5W$bE5IӚijפA]^C:h0=K<éc7跾5煔/(7jHywZEqYt`a@9 c"A6qP6Uw #?quc5 hgЬ^'zt󠦉Omti -ȼI%QÎgVtO;&0boH1qu~.Ts,e1%vY-iRV $ɟs{Ƹg6~HV'ey|>,*ؘ6:4By_f lygm:aMVz@B橄^aNjCǒ9<4́bg#/Oznxlb B+-NA^nkml67/Cr)I伕~7{f\1n7LH~CμӘ=瓛z'?b VDz7Xbw3]p՚8o}[+P0 !Z;P#yL o~ 춮=a=֮MGk+rZX-%ؚ tu\oG iCE!)pʿ@._4s٥W1S7H<'Od_Zν07i>C8aT,y1:=n/khF՚k/'/L1E7,w~ou-ƀraPA\5M*&of(T'-TNs\E:H?.ѫLSy#~w5^Nko 1>Օ rͨnwn^R/1iu]t?1k.n3zT7>SdE99@G;pʿ wNjCkySvIWV]D7S W9VvI<%1>qggh=qGZ͇{ %{bPG^$չٷAIR;?ieuϔ*Xи/u[T~ql@/č;oltڱ^UfOdLU:^Iٮuu9oXUQ&.$U,/~rٙWۯ VަM=yߙsjtMv Wn7I6EvĜ2?mď}Yu>_:Tc@9 0 ( @yh(7|)؎kL=3f#2U*B;E;VnQg+hڞ\má:~U9(%a]* ?`@Fkx=C}.}`/7 jZFّüI9NZQ[>M̠+vq6y_pGxUa \un[.>Mh8%1$~m4VV(l#ӚvUX gb{6WKf.I5ٰ{6UڅXPq.ߢiRg7u4t̿o%7. qPcJq3Ha8̤Sl nyW; :*/dħ4E7,BcX]qKTEEw ; 斆MֽaŞ>s^:[_zA ÀraPAu~|{@&Yn>|}k٩R;v/FֽwcTIo5'lL[pcp"O~6ֽ}1:;7e¥,sqk6a{~/nSҲG!>:RF}uo_OW Q|ըTwz<x0)>qiӵd$&U'4/ @j7 k2͖9t8tíYI{'uݞj{Rד/xYO{%]s}{[z{GS6w-Ճo&I{Ê-=.Wpc0 Àr̓tuKXmíRC~ZۆZq˥/m '=IC?@aPAr I=b~Qh~aHz j߱vE:A+m̜nr! \\Ey*Q)X9wmvfNmt5(r(@T#]c-uZ|iref Kssuòp|O юbI^Tk.(+$URYVU"@9]i^%~ߟF]pd\馗wwynm9R#wLsy[V\A~$q-G="jWOqGyQd/+=s/m=.൭QѮ 1-糒aycUyp}MF1x=d^1l˸!;5%W&b+,N#]HbR,B}%~`fhPnUcaJc3=>nMGQt _Tʴlly)ĻQ]4^( pqY:e"O')msv9li]Wtf;f˻J큡<9rl,܏HDuPYv]y) o%HHoDSIA])c$r<+7Lm4ɽ\"m'|[MkŸv]nYFKm8P1H,j@ 3y4grur {$#Fl{H*, b%=ǎ&cIi-O(n3ْ^ͼ"QAZG<7!DMٖ/.4a@9AꡜnT&)y<;Qhרgjr1Yʯw-o5*ϑd^"R((>bE^@Ý>} @K]M Q(H? l'> bl4KM@>]ōǍe9#2S[fs<_΅lo4`Hܿ*53n`0q9-: .y?\ЧŖkS1so0o pqYPA9f;yqP4HET,(2Bfғ9= t(zoxL`]F?0y7 6 B\u1qZRHOo!Á[zZ6N)jWɃ@og{šr=773_l;nsrpsIX~ArBGy @=N'ژ4ǭV?, =e2ΎQt fiߨ5\CA\&Kͬ6)1w.l_hAGڵi^yBNeߎ ~VUZ J3ŽG.oC@^q`G#~#6_w=&Ojy&/xiӸCgd`~A˪r`zQ3rE jήuZ. 1qʅȱ^4:  ʅg_kF%t3So*GdU啊 ”@y(7նϷ_cU ܡvK'Nt͇Z-7lr8euv.< .Rɴ&)ψo7hLP^oY,Yl~A˪rS;RqA:~űfKQ{ttW)vaq/|H +paVir\. |ڹAӿ+K˔AP%M5I} 9+.÷Sb9:~rOG#bz.N eWwKωO}rR%SQىqYX~2Fa@9A05ٴ̜izS*_qnirP&c!m0ŕq-6FG%-CMA(gG;ّ0G.%<0 !CA,ʉkZ_;K r CA,0 ÀrCAa~AWeX, ^q( ( @9Av1sL^v)=@_ä76{S]t]E_y׊U^F s]؏5_WOvlNU|& (GV!˺֐2 >yk; ۚE?}U_wÀrB eC\&@^%#;Q2,޳ e _v+-fGbG)l٢Fj7-.Rͅʖ"'lzaifM\%A(Qp$1Q䁉r HbR,B9?07o܇SsM|xCҼ"K1?%u/ca Q(s/t9.;>h4梅ߣYK#Osv(e!|rݲ#,үvE쬃{7h<>6navZg)3hz)hloAjiCPo̗rD|{ޗ͗@9AA?*((>bmO"uV:IgXAURZB^~X~KA;ɱ\uQ.Q@ P/*Sxi"RdD(wJwܜfYNBI*5?M=C4坊#8`v7bwʹǎ|{`K`[;v{^>#RDs@f4sq sNEuy ͗DˍT_!p,3#1,mȪ&t_=P7 y6_#TJ 3-BmBy߶C<|zVc8ρ\?ܷ4ZP,$Sn畹 @9R7l8.y_ܤ.~ĵp#cʃW "'rzZߺSU #b8ߍA)_L}]qx&o)hsD~^~A|BZQ1ifpt[9Ƞ o NёmFGwv۹\nĐB97kTMb=[>4N%qq@$=ώRzǏzC7 Tվǭ̎LAuEj橇`#|JJ[F: Sv65$ 񇫝BK2~ ;:7.HdBy(3 @o?.ޏCx,P0R.3)ts_7$_ؑf[~M%nܗs e=_']0sY=f#FYq9:=i,?r=C>S?+B]4"-+҈> fyC9`soiA󬮑i}!澥ع]PNiv2DܪY8|m2W\fOiMӛ3A!$򭏾om0qSiG-sG+gLi9;`spu/']k]TKӞ7NeutB, q)hWˌ6)47k ?S>ajqUW*g|q=멙MpV_ʯ)_oC eEuj蕱S{ odD.u+?" ^owc= #%=:;2; 8&ύVFW)7xM}+K`4t{M⹄fylb{7 nA2vD;Xz_Ҝ{^斞0LV-<.+(R?3"}AFͅnώ5Iw#"~3v9|>x [X;σw^׼/gHԬ+(vkl~sA^^.;}CMA(_;Niv{*kE~.-Wd xFUntɃܴɗ9n;D~F24Z7 ӨҞX3E~neZtz\( pqY5P}N^UdS4V\fyM _ǿ( pqϲ&֚W67 (  \\0 ÀrA..ra@9A(_tuTʧӅ]h o a@9! \\M(*866_=V]66_vϙ; V*um^0Uf{^iU2Sg/p!C=+e]㹋7g?`_֫YF6/"^Pn_0Zʫqe h5A|t~ms=(WO76߉;Zܴ7SpK-Jt5ILm};"ln$0$v4svT.{¶NQ䁉Y8&ŤX|%~`na߸暞DCOrj6=-ױR }&]v;*~879 ݹq 1>u.!K׮)HM5yp)ݷ#!|!ꂫm~a1x=xǺ}ns;A~~%uטl'yEc~Jb/ca 1ͱ̄9PnIpbe!E>wrG\p`{5kqDcw,әU@ۛۢ1qjHAbĻQ9cH}9@[LF`s} RMθ:xK\f߀ٗ͗@9AA@HgrGߵɻeIb+pSE>VdPV()lLẃ Iԉ;6 U0HK?#P-j˓BQsw#q3d^A G7)澥Kd)ܱ ')5h5,7ڛؾӭ p/ ̸ )P΁;)iBsޠwUx䔖IhD@VT&c܈~ czX'rye' @J7?`Y(rS{@PspG}MΣ ni=~uuAFŐ}#^ٴ @&HYE+~9QF~3DbKeV>;n:@z(q#1X=*p3\(_*t,)GڃCHod\}ݠ<#nLyEߐWQY(ѾZZ]}cʎr;hnBBy!  jnf_A^EyV6SWG߷RxS{90u޵N3ͮuȥ6ɞge{ĥJU9;T3嗼)?y^N&Ժw7;.ژ:/5*~ ]yNzrF-v)5ͦwS9"*TpJ7!_uJS|5H3}Q/o5qۜ`+-(Rώ{G(8P3UzXW\fCڙhrJs˞b[j0K8%Z~|3+ 7\}= ϸ}*1HKHSg%TZz}Ϸzjf!Á+гmAJWNJt5v|VZX`4vJwyO LW4vy 4ZO[b!NfmzgTNkzw8]h[T^k[6xiSV::>NCiϱ Id6yO˻nڅQK<@˩&ŵznCʠ׍@qgWA.;2&6zOy3&X$ꭄ.Br9w^`P! r2vQ(wz堬2tnE6gs_j!罹e6YZntrm]TGow/8{4zq.q9i* !@9AB&67Ȕ_Q:2s3U.njj+C @A.ĀEU^frp3:lN}`* P/AAaA0 ÀrPAAaAaa@9(  \0 Àr} 0 0CA.Āra@9AAraP! b@9cB~[6:DMFLfratqC @A(†QfPP/AA30]{w V+!AA(Ձ2spt5qYk&J! bZ3ʗ2<A @A 1}cP  b /AA.j /AA.ʫZZUˏ#.AACв,r@AB A!. AAkSt #U-A"AB@2kS&aPgC> AA x0 /ѡEG[ ^<\0 K1}oU hP> 0ч V[ 0 _Eb~Bo |a^0 P0}@9o ZsP> 0[aA"/äC 0^|Ddˌ|=<䗧B-UD Z O扃fD=Sag3O\J1dgvψ6 P DS 2 !ϋ*"A-ʇI^U1I <">$0z1W؀rtCC.JSsGۘ,'&2,]g~ɧYGI韽9+[3DF,:o9 Ngd+#>gwP0 hi!x5O=PN|F641Ŭ߲3oyZmr=ir ;\9r|#=|5ퟡ6-MӪzؙM\W6_@T'ɥS_OJ'>x5S}գ}M#w߫3~OR.*7PPY ^F[mlЏxV棏>2,.$I#BL%)G?v2mbM 9P~7#fybF;ʹ,F&cNI3rAAgȽO")F4Vݘ}Y3-lox~|OT:M_$)M @0gH~SySryc?i&䧿N-ɷ(~⩸_>!sS. rr t: uWFF[g'32ܳݡO1mL} MB+dKx<-L8񠄅 aAВ=+a!gtd]#K&em ϔ6qP|Q1􄞧?O$^s'_-m}|ׯw|{kҎol|gN;TW>u\xPWEq'+i?ySMfeHO)4S.6V|ozo΁&kkMF62BoJ6ωk~j\Y!Up$jx2gy? :& \m{>(7Hoy4$L@;({?iY(O P_ ) &3TzgG^u8uu(T2N6F)lSm]殿LQgtd|˴ԯ(FMIY}=kZ#Ar7:li3ω_p'6yrƤLC\FۧzN1N6#\. y$=HB4A/}!} M_ 1 VqYX clk!wYa~xN;F9d;Wn;{N?tP3fNy"7\ZYa\Ӏg d_[c|'?R9ή#yK(_ao<ٯmo7\\6 ̠9=1?S>Y̼¦'cG,G$l|@+~rv{rH  hPëNu٧p+tc{bgG~7OD>}B9.6Xf?B:v8= ב߶L|?{lU #]>AGn+o=yA NWPH(aFFSS;-=͟0?5> N-˧i ѯB$ @(kv:Fڝ]$.7.ߡe0* (TudVW!Aa@9U&$UA0!@9* Z,N5  (rS h=0!@9* 0 (rS hA0 R (k j\Ch)A(aP(_yX 0 ϲ5W~hA 00 0c0a@9|U?agK@9aG釪 @0 0} P7GgraC";iAP6w 0 ?F_0 (v(agK@kfp;`b@9ax(a^raC";i}C U {]k.ށ32|@魻gDg*J9i9ޘ[B:}·]=nj%5I +.7Gƀć{&Ek{AzA|ZZ QFΕXcw!3 Օ1;HPsAڝ m]e35`@~dd| ךo{h=|S2C>z(ԾV18uBƲ4So򿜢~|l36-45.3Kot}V#KyB敇~\GZWݨvJC쯹O,#_͆{ SC@\ީ?FL;l.{uܮj̀l@9Wo}BiS7%1|2+Ki-sf>M~jJ"P֬Aخ/=fdF?ތƧ,ۦg[|8\kmtTؗ@33A.}3B:/̣P>h_)ACeO XPݞ:f hc0~P(4#k”%ΜupmDŽd?l9;UlfG\:Fן?.NJ:seQoaap_)qJ+!&X:x!(;aol7rF^tis:-?Ș̭lwtm?!sPFKFթYg_2VaFo>Hb%yC"G C k3c,u|:Hjgd3Fo>/}b {ǫ~rdF_δ^>l-m|E;:r۱axmiAyuiIO'U7MѬ[^l.9z}ѩܴ SR2CaY8)=y3i)gc^i܌02Pޒ,=_(sgvޙETP΃'r>1PA5s) Z[c;N~wyFKjǙR;?757Ό"N0ayS 7ӧ%}>jKT͞sa؎XvY}J1gw"`QA)qHCழS8yvM;aSsfji:a{Sn3+)|O>U{\\-r(nQ6Cյ\GdNGfKo#8;>s=>6lciY}V9}6Ga^ی?5Uv͎|]e0wyw߯>6YQz1کQhVS?1!_Ԑ(+:L(#:=8phP<:hZ3 {B4wFb=Q <ܶ<@ڥu64a`ӣt)ҳ7mb]>a]\e栫~.2G}}?PU9YzіS6x꧳LJ=SE[Ol>Tx_|1kÅcT6-(>垷̉w\y(ÖQR۾9= ΨwZ}%o : f;mVu~mo.bۇ_Ҿ+;J͇[ˢkK7|m?L:,0Vw5<'W;gTS|7_=u?& M᧦X&4KʦoWOuzAyΞvd]TƩKg_G+,m#7mɗّmY(+Wbrt+w[.Gl>6/+f+mDOuۇI$u*Yعg=a?g]{^8Yxs惽ϓ}ҳtS\iϬd$|O;~;BtԷL.kMy=GaMa7厗4قSf\uE@N:Z~c;ևtuZۃ:矞ogZpc+h]E垿Ə'$T6IK?W3cãߝn!גt2bћ2aSO041u./pջ;XZpXW؛.A֟>*`]om(ꞆM7RZj(\?y3ܟ|W1~?ci|g6۹祝nGݙڔQs\ٹFRtuM%Lmc^>@8Bl:g񋁅'I=b܂eʢϰO ʣςї.HzSpvi;SLmz%z[3g|aHWASOOzC_ې5 n?׻t[<&|oJ.^CsJGNW: g@ֳ@#>zJ FC^A٘=@W߹;4 j«z \ OGt#[UCO{yXjN;eٞq=@w&ݿ,}tx>r@⤮+gn '᷵7P+)f/'.=~G' b筽բ{'tfA(X~P>lQKe_^Uy={׹i-ʣBy|M?-z*-d(CId; !}Y_WkQ綺=涾Xa5}U< tʫ7I_^TOV\`．#yeE~n~A.6rBoɲaM^Qj.GE|'#ms|-80!z3onS<+[8MN|4?^ eGp`[鱳ʾS -we0V s}mA ѧ#!]fG+Dy~@ eI7C7 ԁs3X;O m?LL͋=ʡP>L:-0 0} h C^&8FGbŏk-~:J^z|f (_9ǟ0 j%5I356i|ީ4٭gǀr@9 0 !hPna^raCbax)(w0 j% @9 /ڇW ݊ (aaPAuWzsRbSi>F-u{zdЊKp&9vˊk;7,374po~Pw,Wo98,:0CY(Z!iaojl@9aʠP}BʸPe$Mgԃ߻v>yܢ7Fڷ6\{h8{rb0'ʜzu{6iwEf^QL0 (q?taaY5Кu緫\yTEfN?<,}hPGw?n"hHY6H36wb}]|گm9;yH_J{tںŻDŽO*;sl˞)k[b_UX->wkKdlr C̱B5P<SEٷLy8v4awy=}d<ɮhCU}aUf[kjăn PV(:ovN5yP5R]|<uI]^~~P2@$=(K~ ] őz_P(aa@9-ʭS=n@~Kmn.=Um7(({PxJ@c6!Zm|FG& =>;׿(s tiS]!P=Ofd{)wO=Ihi;w&4d&=]QW7 }}V9F)՝AF}J =ǯO*lzuϗWhWvL%5_X I8xϧLw&pz|B,3PZƆOH~l>׽+⯆i64r#Ii.NX:dz){Ywy=pv5yEufWYS6g-m611M(*(XP( Mt`@0J9;\ >G.N3ð+;K3Q281zX|c|caaaaa=>60Oki|x\_R+5*Fbqi!@z]fʶ6XF9(N| OrjĘri>Xj/ZK@{=k'n1PEnB u띐j4[MX;}1NlO+>j\ lʁzM'7,i`3 FE/xׯ {WdW? sa6$M&I\?6\H ~fz jbT_=eT{Eu.ɥprxWͰ 2H4LQD'BLBc=81l?&Sj`A"&rwQ h&q@$S^@D"~Emj$-6Mg*u*c}!cirx \ Qp=~*>?? -0XJ=P1> ֳ*W/W|>d߅ۯu[̚3oz˸F]6im\Ti34nX~<*#E6 X+0c(P|!C+lJP6C]C,_SwbVAzxJ@ݙPG[ypoyJ-EP>xojlu A96&\a?MBF%D/t֢]1!2|Nmw_i'4e Ǻ=]@ҩBy}BL$iMT=vq΄Z7GGYn=Xe -'~Vg46Ķ&\e:J.K<]mB[_M'Ԟ aӪʛ&ͻRUHg>sl[@&"ی0x#xu؇`y]}Z:]K!2nN޽>{5"uөvER;G;Ҿ/ohߣ{i7M+WDyX|ꂏ3[|=kPa< %LCܥbߗOԢ@uC@-7he|O %֥[ ܰa[ߥo hK/nxyT4űO, ʱ%Z'`X,EFZ<)׵֤Оӟb('k֧\ʱ0c(P.d68$ j4$n=ʻ|oҭ[hnv_(n G,Ž !s^~牌C(;[3{x`$o95WhwdA脰H;TGXAL,Y_߼dDǾ?qąN:,-Ms#Rx{~sZ:0F_@kx }H(O)^:)Tǒ5Hh>=tV c 6 >Kq t"^ŷ5|c8#Vc?+Hiðb]S5&APӠx)C3p9Q}"(O>r|c'ii%JفrM piZXl#D*dA3UZ&,nIU&t@T;J 5@d#\yg[L~0'f5&_sacZ46Xx"v'Z]v#́`;Q8 aZjScXv jqIH 9&۔h: {$O9ѳBĀ!5 ~ <co{EA8yT~yIwcP|`(Pe%IЮ:r=w@\wUXZ}[:1%+ BKӱ~<=[!W {gV>]/_YB,}<2G۹y|%f<iU~KWN1Z ZZ92hl 6woXwg%2}9 y{.sq`p:sjaub>wXXk)<džaaaaDCLbp`]:2 W~mʧf˟P)0^N߽& n?aAX1 G~9| 4}W[\ kf(8|@7<=4 пXޮ4B|۔21n z)ıuD] ⚢O|V0g 5ޖoϖ#=bJNq3 4n2whձf^mB{lzﭳMn_<_2EaA_JQVwϲ5wP[B^^[-jog>&2@٣aWe+=U4ފѠ–zHcZm |eX' m!Zt&^X^\R4I1K/C[SE"MZs |l3XXXX+gʝzo/i߉# -< ' no7/^/z)FįH>P!8-8pcRxEYv0YVбH!G7^L"o? jp3i?v-TؔUg H"pd,cw뼙 YybMk Qf6?5(jnE+'Ff0 F0Z0?KPN`ǹjasë%טbؤmO}čkA6YKY3]6IZՇ+\+NcC+1v6$=h==%mX C9KcCNi9Jكr,,B_8пm V㕱)jy^KϘcX XXX13(wMyV(spPV&*f{o˳wqP>#{RdOZ3a(PX$m4-}ZzpOE`ȾPH/M]ҿi(?;ȱ>k]1AyBRBzDƌQ>;|Z}a(PXPhO櫽Ri@m%8|o]li@yC1˯pkP~CKP*TK 2ѥrJk4mB C9>VXXXXXXϪ\ʍ3d߿vfnva|/4S2>3^W)${r'.oBCr!n.Ǘ |~9TPh5Ou!3IR%H.nkAIE}LfjH)(9Y9Z{޳ K ϑ|~a(!۩*M^zv5Jszڻ?}7c+ݾ+TksD{r Ȱ"%vJh-q! eT r?1&/gaÜd9 `)_> @iqqccyMZb_)sz,il]։-[ȯAvBWܻק˘CBmM8^95`?0 S<% ʱ0k<1!3S arnQ;QOlo]lLPE3$j^*?ϵ#(WK|(9 @W'd7Qѣr 㕒y=.VP/( 5+5=#Rفa{QDI ~M};A,x| ;S)ɽ*ݭ1 %lm+G~t}-J#6S?1^`l--7~/E%6g@+y mhs<%}>R\̕B?X-S >@A?gO(8(4y> ̇o)޹Q>;_r@^id7JbPL}caaaaa=g\ d2f'k1K46]<20^=?2)Iwf%юW|1ӄV%~B\FEu\Īl-?b&?ǔnt}M\/N{4 r)j|oeʮWIUp}|.qEc7_,Nq2d,'ĤNor5&"]r5zT_.~po[TOݠn0kq4njVh[3\ȇn˘9"ᘥ8St9ɤKci2r,弇Rb7Agrxi%cjh\}oޅP>t߂ڢxj⊪aCI$v9KQ1caaaaa?xxơ+ TVP+J{|;&(@yR1\" 0p mVN *b@өw3w" ʗe/A犊k/*]D{ЎX~DG0XXDCPIG3ׅl 4V |9p'+/7~4(_80{lt؎PI%HPPHJU|E!>(fN6UtaZ!P6 1hPL[]S.,,,,,gUx. ;IE4]#cl=꠮MDΰ'CP!" .O")mRN2-rh\)P.W,T}շ&[ozZ9Q^na[*~Ri寔 A1?9~h_.qi/j{k^FFLF+*2נ} 58WE,^ h{nF}X6bL{mb{ bH : 5=&S/?" I-ׅ6/^剘Ur/ʦe-\^&y=Ʊ zHzB*Ο3 yEUj'#1L ]Aτ]t ()Ku,E C9r,,,,,, 2'iR08]_xPAC+UŒ ,l=?W!Jfw9dD;.a?2?=jDr+qsY ۣգ 5( ۪ͱmjFۛ+ wV^I#{sb_}^Q}+˴+]l t}/*ÿ|+Tl"% }e.EDBwES{p |yOsy@>d+oYY^8讫W*jzuo-)'ֳ*<3p_&"H̘-{#npO\q;1cm|iuNуb_6F;, پOֻ2baa CgCNtK1~Hi[:u9~pyW_כxf:2:+'-6'ȝN,8TbpP|ĚI:VLJY,,8a(0PH*'Ν.[t6ݹvI݃C"pMWְ5B1wjYW!|Ap|6!lU5FH˲>͘KV>︛gxish)XU.LҡaWÀѵ\:lI/>p“RyiW T ڕykmO41Vٲ-! r(CN?6\,,,C7 K2][ox7Z5'۲\߼jPfTpPKjq\i\dC]~qZﭟ}AޖiҨtLϝV_mkr_7*㎝i;|Ir,tK&pS9*u^Ο0?Hw*mzR2`-$p}Q ( QmOz?s7=)غWdߝ:GԿ}w*b3#2v0bL#ʏj3DRCm.8 ȱN/m(V#X;}ߒ(/?X`@MϥJq ΋_C(l-so=GIH-nMOoΕ@S#1XO$P#9wF|BcrrMdhof.3o^|\//y⼗vHJ {*z_ ?c7'I>Smܩp|XHkys |`(P|C9ѽL(O5 =R^N"~'%n q'CCj׃[p@ :Q^#xꉁZʵ4m+:xw=j ~x@mE}UOxx[/F!t@dCv^-~xD̞̯ށzjfDc hö'Pppے95:qΞ~uWaw܍b(G7>V*|^wO#wrF71b ;y7 r @bUbs'jjkr&w. A1JKފ1/g8SM1 -\J}3_Jٜ`zPv>Sn'*_%ߋHJ٠# T=!w\e(@=tk'tV&XOa:TTx dM 7Q1>!>y$sB[cyrx#ph=gc&΅C9>h&M.؈">˼q 1ڨP1>M){RYt՞ 3wnAfO v8괸zn{(뼘`ܯrڥ@oXIOvZţ~ƛ5ggw]\[!9h Mڐ^W 7> z.fWjeo {TZ/hPa u. eR7?Zk)2Bв9ؒ F@b|Z2W7r*&P'o]9K<バ)M%Ir ;=إ#0VRce]?\G?\r-b1t'ߋ;%|DPS'AZb_VM7:("s'Vz\t&nGF1Äz-tE>sYOopgݧAm?s~)_UJ`Pbvת"CbOluHjLjܱI]h_mM=rUX~^ %𱑡wLrYC"#S15k Ni> RnZ'#)q.׫J1OY' C3.g}TK@y;)1 VH-PN^5o 'V{ n|"U@!\l; &VWٳr=j]Rzq|(nۑ^1'L(Hg4eÓ0dF$8Ÿ\бXm"s2yp5\b<%Jt:bb_X jXPNH1+*T9텗8 S H!9Άq,ss'.;^'HP EBxeJ[|֛Į -*wT-YB!>&z#g DzAϸtiwW@2^;K/JzĠz)~?!^̇gZI\Q9  =Xba(P@yMvo O\ȕ07r$,8!Jg_*̰pٍV7S|9۱iз*^^ m^>de W d0ٙ-n[8AZ z[aed+^o GMb3}oQ|J#K }Xy/DkسT"SC*' =v)hPޘ=ia-P:nf"8lUW@1b0/eߜ*{@lECbd.i~>9v |[JF\KS |q; Ğ r;䳄~-Rw$P_Ѐ07r9Z-Z7u1s&rpP2g߀9ۤP#X'ihЊtӼF|l{hgh_t3^+$ܺ`l꧷ x]k.]T7F'[ë{ dߠV)כFc{ypzuy_J7`N߯7~Mȹ2bPH杓SX9Pz,'_p}{]Or=>&|m7- /Eˌ8.|Cwc<KտH7(JmLb'a( Pnd\kx Ws}EGeDiܠL`爛zhwJ: >T#-{E>M<$aHp5R.:xnQQ?*s "zOfpyPs{MPy&@Fp~._ uOz@==B9o@'8A+sC}a[wOI:$;ǗTR?Dl1dqD<-S)7$Hhpǔ4b'ajT$A?Q1JJ7ڂVanX@ηc4ҏdR7};mh;ɘa[wssT;Q$U^KوGyt*nۑ ~|KDx+mѹ^ُ#-Y,RE5DwC1kw/W+ r76$Je %q\ &I$sM4_ en{wa|.?vkTݑ1X愊;9S՛cK뗀Н~N?Hӛ͢6xDΟgTEơ_顂1NCU7Aw dZ}gI+SVPx~`PG(ߋ0ڪ8yR4iB}ҸnUnU[e 4D>/8 |Y܏uXۓJjr9?D1;cXz` ck} CF-;UN^tlgGe㶷i[h?,}Ÿ#o)khfZ͹ uRTeD2gd1ިWJgLV^Іj}t*I9n +EݠnNj<}1Gr}Au Mp|EornĜJnEf2gY2WWga}Qlᠯ.݄/>i[)>|2Z dy\>sOގ~,T20Vx5nZ;lwNsb wnI^\ʹ4r_W;\قn:h7S߯]}"(2*d\-va*U@P_ؚ1$ܤy6s45Quk.SI [yG-_ rȲ}c9I0 蟈[EʿV>˥ڗ "}q!_\{%YY_g UNŅ7H87 `,*ˉ{bXڃlr_vV,c@XaD IܲkW18P,A9!wgabdē-æǚ:lRӦ^qK)V`/mMKN̘ĉDek4rbzjPR 썌E*c4GS_kl,G7ϫIt.n jϓx!1axP|, :;Cc')wf5ZKEqڝhsulÏ,nF /~-*%Sݾ+#>Je$d6!ʥe E2yvoQYR\t`ߏd;!VI#[aZ^n1/g`PA9bN4.&ixM 9$Ts`EM [9r|@h2 PP`G"EB4 t}<~zȖk>ѪCeRhC\P#Q >),S! l<KE}> n9}/9g<,e?-X(8,Ϗsvc_wm" X9H%F_MxDؽ\N­W:ԂI8*5? C7ۧKf-ovuVV'1[&*J::nkc4lIzoup"<3 B07(%t|lWNGOopuU|*OWo(F+TF?AfЍ^řLlҡUوFGھnKzeRWG3w':^! KYsWL@>/b1L%FD}(NJy]\֟C}>_pP$\ XPxP>;TQuA\Iam(T0x,7:f]+V:J=R/ qO @{|P~v#T&ݿ|C I HhlD4N˄Y6oXX˗2o@ g, %CpR3*|~s ,XX1c(GrZ?;{Be"5򞸣 ϏkQ?P:Y? כY> P]k{Lz-{&ۺj-/~tO>Iy#N;Fk=,||4@~~GƣI<9`w+OX|=cgjTTʶo_CrrZN2\Ѻo<Xbz:;ޟ]z!Rz,:ڳ2-Cb_۾ܖjO&@˙5pÿ|]j״6/> 1Ÿۦ[akBr;I56nd캵C8(mu̫%KTV:%zW>&<caaaa(PnNNo\J7񨮟mz{cxր+͹dw6z /87?;}-qԾ|@;21? oQ+\Ѥ4Ns|t: x[ZZ3z.7}<3|e/eR\ y]w kVٍdۯHV~{~՘$FrN2>8^ 0Ͷ(Lr;N>:Zp˻)S`q#+|om),dd d'tMVU`@6xٰiR6tў\T^'_fP 6}Q-1gl?3rNedq"{5{$^nv|x)tXEkR7I1r۝uo8i nwX)$6 B\)`JmrSt9&:JXAA5fZy}py91Ҡ`NzPeßPO2l$mi _@|ro/Uz Tf9P@vh-N8Qt/h]O%JiŕS]P Ɠyw[y{&t_Y{kA'a{)zjs/B},rz!n KՖYGЯ.ژiooں@=3|o0;r[F/DT\"i&'9{_]W>ǡ;U;S`Y챒<>^m}}Ҿ؟? eN 2Gm?0Z9R?ʅPC3zIkQH?>`oXpB+uҾbPmK00v_m @/lC/@P~nеʩ{+]'p#G/^t( NjQt>-rp̞f `tD@Q/㍚y% 4ǂj@ cv @1NXHj+?BY ,aYXKp\*6ssI <gZod-ƎIrpK46|1A6%GNJiJ=7R&BN"VП\OoxQ[ɾ0YgxoD׽Ǭā/ =s8WG11؉6xP|`(P<.ÉА)քXYOJ L0.n Ѐ~uNhU\@BRkK0 ʓCs2^w+?qz?¦x1"D$7 Xbr<<+du31m_ߥgV]rzB7Z X7p.z`Ҙsʞ qb0@;]1_Ā$~F[Oj"T;9fbKpeB%?XhѠ[`"li0y/`Vc%F-2N&sCIqÝY.B)ga$xP|`(P AS2I*qQ/1NY -`"1]d\/,e 69ep2Z)'뻬hc74 r%a2UOgQL3mLڊMWlfpzĽLJx-ؤ6ŋQ&=W"s*l}qdu]_KNcf!F};,Gt9}ʧG!f}kW'l3=T) fgw CxLls * ~>ǃSr8biz-r >L0+*F_Ljyd)%3RJΣ"rА /r֔sdN"xLiB}-c31w>,)㍃eqPoxc%F7va]CJ mK/u}q؟c|bzO-^2?)-Td&^jd4}b*-s&t 48>z7XY}F='i-S>0caaa(P>e\Mi NX4jhc^oi<+GXvV.iTXV#BԞkBxڌ2c|Pud$űiI~k3n{oq1ިW(OI1⠓MT+dj~>/'KC9r ʧOCVXXqp:ax73v?#V]x. XXX1`4>"0O?,DIك+TgXr5d9Z}>0caaa(P:mzVPC9r,,,,,, r,,, PR]ePbW{gUOR]vsMp2y 2}Uc(r,,,, :_/8rNdڢ߈k^hUQN!$s&:p[.{wB%RfİrYO[C ݴ*?e;zn u5Prrrg1w=;oX˗WvGܟOO^W9Ln+2s |`(PC [? \4u Kek C@,5sU$(kE a}rI@ʢylB5tdOi߷GnPY#|?e1/AOO=ƥ*Gl"S*_fLo~/H5̿/4w[8/O+ 7 vDaǑsh)5lig2?O\ʱ0c(P>2?|V}71W !u{cxjVAnR,C,ߞUmt]xaǹ7!:?5} Y[oJ/"|Ԋ/q/~|$ <S]V65w25hUIz::f^:C[`6Q& kǩ`"vq_[au~y`Jm*l"_p[ыNB6bIȰj{gy(*+ =@ Cއ/8\ /VV@Ė2]N3./i 'k!/m/ \b2?mF‡Б#v.n׫)䦷'Y{1bŻϳT?o6rwQp.|j_;V~4Cgje{AEUv'v ?C9>0caaaa(>`’L"V vV=rY6j]d80}1z&t1zT p6ɭe|xlK DTfL3+M#J5YU"ypHY_pnV7,LTYVk}>|MϣަF 1$Gz|hk}|/$Hz"tJ7tO >P{vXc ՟ّ1b&]4Ap^^ݧ=A~6eujuίs-z8?R'|(]QeL6}υ.n9KgRE#G,?!'TRCWC1= ˿̕v^h]2 b1JLNHsa e^tie&ߕ|o+Lᙇ9-Q/l6CZ9Y%ˍ|Y73~^4H\W% P"vsP{qDI?_˸g BUWkEviJRyVV2^>UH O !'3 ";R.<r,,, 9OIWg5q|nNu &So; _'^:sSuDqjnOk8nT \I^Nj&H{zM־;Ań:S',}=#oq9.5O3}Dmֱyf*n#O :]LM?.$N=_y_c9= *G@;uݩbݞW'Q;IyugDoi4 yb1<g"lS'7F0>eV,kԴ{q:Eڰ 0*B?::nNQfJ8~#s Ky8U gI7nY29v"E?_crUVĜ4žn4FR}믈Ye?Z^9gz9x. XXX1o(IKYpR{!6'@DDl[]|xа jȾzsȝwO93U~f3?f?twܯuBUMk$ {y~mdj,~*2e*{⽌M9C"~wFӠJdj5ORZj -y(6[2`5%^܉Xz/*J9!,n8grcNH#5xuW3 N ֬̕_\aZ_8E F/KÑRufA?n` ]+jST\T~_xS' e܂qԡ|zڠgXl=rﺂt]O؟% cE"_bY\ J}s0Fs}3gg_|PC<Db2yKdn]!7nC+cfsʏ|T/6K,^}I}7[i` p'dԄYݪ6ź~oM&p P9 nZA 5ȣc5X,ix:PN mEO/x*mgCh|IVNUpo0~y`Qlz&֯'n;xy<(WuM,Qr|Cw/I%sQ|Xn#hE dɍl= Y'#41cbcxձm>h'GeC/}/|Wlw.P-1/ bt0caaaa(6|ZL`rHD`Rب Wf';o$ [ N8Įhb pU\E +Zvv@G$±nPk^m&"rToywa@|*ւ*#PEati$G^#A1t{74~ԡ'Wpn=94.΄]XLgD|p+ekZbârtvUhL\1 RB0.q imG%ޘe_^'M˻ .-]Y֒,7c]X{2]3pu$3A|]%>BPϼ~!Q|Жgl1lGeoKllT(_}>]C T|owS]x. XXX1{ t%,Ԋ'=}6vm'ڕ&ذ^HGlw4&b7dY1Otv82<Q7Tbe].-Rv]FA~h"`::J`2ɥڽ_fOEN 89֑h_'Bb@!x+S[EW[垩]3pmBGWk'ͱc}NܜEK[ގKצ[7KvmĽ~F]e?η2S AhNؾDcx5$j{ǡ>_Z}K4347v&T;uL&3A,Iuo~P]_L-[F9zM?L># .^` @ c0rPPC@o`PP-N4iB_אkc7UmHcy1ÑyAKӈIn{izry@%rh6W-/\ C&|ހBKs |i?ݣ$ ,ဟM;_mPUO5?qAgJJjt_VQSb? uS2f~[a-/ݶX'%:(pͽ6`wE}Ǡ&tMaQev ࿫SO|Um:j@˥p_A) J^f]dM=7CBAN;%]}1;Uqor|U%'#dXbVXUM^ri+Ƹ]F IӤhߏ .jB)flq/ -= $ًA$3DiesG*WW߳e1mWr007:&jEȇ:AWʍjZ~tiNbh~yoLrKpZxIۯxt5yGшЯ[VN-讕k:ش]^{zRUOo񛵇f.:,~8G뇜Wj!Pnd5u֛qG*%=[|+<%05ȿ ]-!,阃Y4lWiQ\?z(wUKpiu _yu1G[;\s&lqcɵ;l,q֞y!:Z§-O9=Lnui(*ep/3e-c~OyuȘx<{~y!34P/sͶ͵A+R:oO7DU8 r49@4"Phba%>?'R|_q7[͖Fncߦ}jt󾨿dzk7?mW5?0+Fsb a˂8{sx(GD!>tOW> &gz s~b7BEPnd343 &|oOOb1d}0#gx*'ͭ_r@eޏϯ͜? ǯBZwbJO8qöu(7j&~q}5Ԇ}EVn{Q5h%kTtɧl=Y"WKde<\/Wz9k`Ѐ%d RG=d,,v,#vײ.TB#>ŸEN0 yײcdT0[f5jmo?6g wN2d#x{pU ,x<~c'uv9L7b]FƍWi`ERJڤŦ ]]}s:[iqSQ̜@MG2dʂYf[m1bVŒɸ~'RٲU0u< !ugؿW+xM;Ȧ_k }ڳ3X%FhjQgz)0{c hC$I-ZJNˀ^f-VZӻ8̶e}.%~j6>#+9gO?|VAC̹,rWK]z\!n?pXpAbug`c. @V&UztY g)yP_g`]Jˤ*㩃gݾ;}s?c1?pG| 2W}[\8rC4[>8?3Qs=E]#P`y:M6(?`Hѡ6-s%sr>\ƿS-pߗ* |iC3gaLw-촛|~6S!z*IJsn! +|nBW_L|6l_c[Lyn }/g mb񱂁H~WzxBI[z8Ol }^k]vZGP. 5```o#/_w0PPJTHY@|WVR~hUJ gOGH~le |9k7kݢCuM7A|Y 7O;9+A>*PWJSP%Њd3Nu" Kmգ*roL8] g5\: A9[$Y}1yXPTVUp)پAyֻ \J|0m0LjNTz0( y!@U,`?OX B p+K`Eb2PCƢo}7hW%YjD-EEɮSŦ,ԧYĻJ7b6󽋬,VÉv{jky 3duHd &ϓԢ0/c={R~?yMrCb5*;P|;DV1ڿ w?((3Wm.>r- mo#&4 mOi<Y6r-[06zkuܬ;6[/{0_O *Z'?CC9D1oVU@(WC&hz_ѫ혯*myivW" Q^+̕כ8m&$ }q2OTC{,3Qe :<#{]4 D 4WBrHdA{t&aΣgbeg"3XK,l 9a9A>_EL-Z}:,Tf]n># _"̶Er00KrjPP귁/4&^w5AOi6G7O5dPFywD/T9 _R:x)Q=݇cvakC1[Jc{_ "͞[ߔ0媼چkG?r2_} rYr>/*$?PmS_/ׯ[p>08 YpSӿ?`ZBy8ΆK=U]D F=FwV]F^9({ rH\[`Ğ{܊5y5^a'2včrBbwQ:3EJ'1U%c007 G4#Zh]Jm"7(Rz-?ѽ :eNE=_Z n[SRF{ePw#IwSLQ6ђX0{PnoN$+`.z$S7l.e$R@2; 4hIuاMT@APnϠ60iWmJLުԆ .Qzsڶ&UΌf}3]MP}3@WOm@~$}Z!jSWynH @9@9 :A & ```/xJG:ԈI9#OYG $o*U;oSA)Y^uIooD&3[ؽTwmQ6{[F=wPQ\gn7e7ߪٔj:iFГ^O}'L $vP}Ͷ X@ zSc00 e.[fʌؙfՔaTԪ\`V͘;Xѹ _ ;oVߗ#wvV$Bv 9fʊoz)49'?{Άl^SNrr0iL.T)zC_Wkc0@ r000PWw)^ƶWVa*EPce tKoxڐWgS))ʟ9L?ݢ> U|/wBA9>2Oh2Vͅ~Vnmrmd9饶:}4i_U:]?ZGwݡ ̿$%i0O:=JǤ/x:0.~^{T4D_J7);KUެ~'n0ǷΔxO'?^;dz|^`⡜*>y:C / =SwRF\JQSMԔ^=T@G+XF$rtA_z MO|͠WSeo:c>|RѧtՕ-B-JȂP{tcCF>bàiTݫ j\#Pkw;G+5_]s{2M){FlD[뭍]ō%F<]{l3hzG{poʨE"Pf;B@9PS|$DY(g-Lyv4 tޫR|9]U2ytė+QQɫýS o4I&^,Sh_dN|e;*3j(䏫 k>K{Y>A# Hw?IIG|dsmm#7ru}+ۉTe lH?[m"ϯr{R%Дs옃AqC&vfШב-寽9Ӂ?ăskk$-)3c8>/(Ǵm\Ӟ֠: &w?u Ç;1+"]Yy7\z|/gm֌ќ~hqo6[N=Mk1U^g{f}]Mׁ `(M@qCkWUn7cZ5/|6p%SJ1s3[ݼ^v"݅0IYKk/H%oəzQ0{iP*ؔwrPS Njҏxϻupʣ54@iduI7`k5730 Iࣀ*YCoi0%sA hx:9JSo{}ya8`)Cii]ZۢXX0H(Z>R{RzۮÓlK&^pb^~أiiV0PΔNhuZfK{*Vz bbV-.su5!-_dN8O@|}.4w(b-':$Rm:FVo+4M5MƯӞWMj|PNa'"A r000rrW <,+FVd,+nD5ٕrzT2ԜՀWG̴6xsݷͻދi'ήZ{|+nۡ4e%f <ØeF+ǴR1('V@Jq]V 6Wm]9knq֞ᒢ3克x#!--qZ},;E C^BEy|>矎mЕ7kJ}M]G?ٙYѣi"ykU CvXs|5B?4A r000rrW'JUfVN];h0fP<R*/Y@5cQCp:co;$(~7lfNRrk]uM~1o-{ [3x#]䧧,rS}iXKZ&svT{F+1 *:U}{N~'8t qp|猁q57r3Qi ?gU_^&}#u r |{\4JɌa Ff>/s&cO ZbH{–%:Cct=a2E|0|frU (3{,c(cAiGKAVQ%s"$d_SΈz?A7E0((p(UJ=w \rv5MV/mҕgd7+|=[c=/ijͬ}4`-`PPhm5!>&P4uKEv- $TEG]n&\:aRHhȫUEoZ t}B#ĞtW@ r00) ZǢ Z@ zCP2-Fr%@o<@΀@ P(/ѩi]J%u6V((@'L9jVOmn|mg׽k唥v{75jG9TKPmj&\·O5+b/P(oA"DOϒ_elIv4[)[斳6iSq֛{[KWn((v1[ۻ:T`^s|`TdM m/wK}X1 z (~ O&Ht^ T\?ώ˅UR t{~Y7~YuIO/j"ز_~E!r000rC^E,إT`tG(v` ,[eQݹfvU4$ 8qwwoks+lҒ*=F" 0`J6܇{Vlǐb7ZSRpp8`^wivܛ {w6vV+w:fU;>5Y4x'G'=Grp̢0rø"QN6Ϥi:/B1=Pelbbuh!ݮg=e5"f&^'}q\рϷ-i+L{1_?- 5?Xz*ϗ% e  l| A (J-hIdT8Ht.s"^9wƦ(BN?x{@C-'B?؆A00_9unN$WiBBT+r`$=HbCp%zr%a1.Q4k ]<Y7eOjPyp6YTfg՛5B퀢_%AY]ѮkoL܍/\*a ˖uGAU'FS쯨@YsgZy H'bPǶK<3G!ԺyR +.l+=R۔p^__6/@E luؔ߉X^呔-ԗW&d"N;T*36~CD!sCq(ha4C9 a+/]Im1?D=E|ؠn۔ D,nN|<yl\>ٸ yv+ ˄:⾘@iS!Η h1((c*K>?oMj@?Nۉc6wjc k ܑ)q2./n Ȁ}͝iAH`qc"R9sr!^<߇>TN(}h.~'+ar:ļ 2Y]M3>Κs_Eo6v5RMa\.7kԚۋݵ!%nMq_Mc@IC+OJaCbů/#*7)"|wXDݩxrƻFO !Kgg6u"W.Η  ( ,W3)s0{jWݬ3(wO~}IgZ {{}G 3kf8!6HVSUt7[f>f4~4O8?t|q[^,e.q|_A=<ޑAwoȇ:..gGEP_m9\&w+*oH`+^.<\_;;I -tlҫexrwXMMV{|vu#;ͅcDGq>n9^sz/8}_?}ggrvs]{;WkcoU?v̤? JS0+>3NƙusL^r3 ʦwа&M~] pQ< @9;pv:8v9_?ATTJdsιd|K&6Ac1:s\;P1{L(KS-,[/@```W[MONP.!ך9O ; ɹH4O}>-$ݥ\ʷ0\>yʿhiNicf+yOd<@ PC AM4ps+'w:m_"((|[r3iϠ@8Yy{&+i) ;OCխԜo-@NTt%Ғ)JA zSP}z5,{n/ϕ:|Օw&ٕreG!D6yAS=(}B |t̻˟Z,Ox% O=[F^<ܺ'O*&Uϡ,O#?C ' mOWSоA ([F(wA6ףGϗ*9Y)/yg>=Ə}C]JC8珇y}A/3=/}ɧ}r k Qa%O>*D𔛟ES1N[oVvMgV?81 m @ r000P'WON9WySa:q;^?G}D^s~Ry6tٕIg Y)?Ak,\~gRǜtwfyʕhIsI5.\y+ oRA[@D``` /uҨ@r{B^w{optε~t_pA[dH#zCZ2z%KQD'lKg)j"Sȵ]-4.]Lcx OAEN-o'_=Qo㿬򣮧T+?*(Ojoʅ=}?;x-Tr?&)dLluvIM TAy1ϫ|PPh(FPppy$;D^@_[ޜǽyƻYb67 .4hD:ς"[\FSU /*bՆrU/*Dhmr)vEr#[̎K.nY"ByԾ-.yA^QޤVjp\y}RgU ד?sܗhOaLvʤQ.A-+V@z b^7P5E```; ^78:ƊMJ`(Wȕ}+Ǩe57+>Xwq_OUw7^+E {Gr[Vobn/YyzS/[|D=Ž5Ǧ:98MxA~Iqb羕xdЊF.R/iwLV{x v\+2K[Sc<9O$n=&Kgm*|YLwQl*k $ϴ֯Qï|鯍G&(2G0s. ûOY }d(I>z((;dJ<.]rܾl⍋?Kڇ2o}u ugk>7$pNKb6РgT': ʑl^[tbnR:gᘦu8e9WXq֜NSIǞr~7eQ~vj4nɼ>~g'\ ׂc3I2$MsvDO3J9?t}[ PP;Ht6Hɀ4۩1nt P瀲g@7' :қ܋ni'ows[,tېy}-w|EG>'r _W lJIL;z[ l>; )y8nìyv/?W=mWf9xȖWǻD:WqCoﱊgWe_'Q`u*gYOׂcêL\Jr8}\3 IKy8?abCOELFش>AK@9¡51@jPeږ˝v&n5`^@tO~#|ʪ%jx3N[?j:tOƂ @j@xr=.NXym@P GR|k.רVk;t:۹9$/ FHb;b{qc6tq=^A@AL+Qb| KV^s&O0.~Tޮi.V-\rvkʻV;\So7#Xg@:&>Ul1)yj'#XP޸8B u=.9M|m|lf k^_2i,v%rsMZ6}%4+WOqVltLU$b-9gIg!k."H!Jpx#h1938nyzؿkog{H}P@nH܎vLN! zvyڜ|%P[P͝fi)gϘkט\ >,s<@vA6E)! vY`Wʂ.Lp+ _4G.'1 ,I_u;ЅDd'6hH_RlûA&Cjc]uقe;yW,hye՛f/:\lT+@GhP#>CWN~{6t{v؋}?@(p8ןp-.de}?xqN5HUd7=Oe㺜*&2~&8~Qly&tw1s̄ 3@9@9(ǃBQ$eOr[2E:gTGU z=>M.+3ۆ}{]" єK *I?.׮1ū[0lu.9}#";֩MYQA܇zei:uczsXߖR彸-~纙H5?#JZC^OT o6Nufc{i:6)ev }~tRJ%ԿCap'twQ_S^:ߍ2/ZExrlu-)%9B))tJAQaQO\gLv gh$wi(c ^?./ +?e)Kv @#ka(NdPNa )*&Rrr`H*H~*2;\jB=]vS~D@;(ے VDt?R'ޗ)i\ta^'gMt!%% [LboL9I/>$S,!'=㸟pQ,$bx3Y?OU1ҫ'{?|A@%W2LhpP~+>~׫X+&21ƌϝ={ӐOq:fr000rPp\tBvĶq[P?Db-'(˽f@_7+rJ#;\Y$H*2)n-[<:*aoߎT8*X`;`C 5i(#T߇`RA2[;%d&=J~"?o:K ߴsz%~qؕr8oK۬)m7ѣщ V͉ 즪j/4W9˺ KVw4du[AoUGO.|k +u&7N>9O_ A.α.}8h7MgLB$?WWQx Մa4@hT(xQK"Ƅ]!Q~L\N$zP;:8P¥u N]|IBT*+YP|8b:d?!OX @P1S[9C} lv w#_]S^^DcxC]\3>>c'n6  ldVKr @omT\3((@OcAhL0F-~*hT{<,1@rL@ P(@  P.@ M@9b@jP.CT@ r^K-6e{9 + |T-ʝr2K{I8Iqb)I-&8[C ^?zƉE*ksy1rܫq_Li>y@ r00 CR7'vUJf]vu%ކq70)mT)FxpC'JGgwT'|KDbR^|li r(u{p۔ޭsǩUP=μ8j{ȞJ/bS)^oJ=5h͖bVTi4"ٵ)N EZGuX!Y:p~ޥ1N]J ʑ?'a',9ʳF7mzF(H:;uĐ=TWS[9gܪx&6iqfxu~kTzѳO"k;<[>=Cۇ1C$@7U```rW$IPΕGL^MtPIH@Z|c9P7@#s㌙6[pW2ǯػL. 'U#*\s7>z+/ ˇowh L) Jήj&{#74dwU卲P@di40Mԅ'Ny˫OL2uN^TD6uZ8)lJܸ--ؗ5g*_~S &%Ȼ8ʉM*rzo ~CjkՁ.(igM[\@ PPn IC ).j}kCkU/{JBP*E4U^s6AŻm܉Vՠ[Pw̹22 s+eAׄw~+ͺ:Ȧ)ae͖gfvd^cǞw.`xԧ>DtN{o*$=Yvx-8|w*jrtHGdt]zdqLO3DJTRjr,ڰn?@oA ([F(tN8#&u'8NCCITmz_x+X"7A7}nY{V< |?2r kpy^'cr8-ҢFu[cJa?LHs77z8U9_Vx8mDe'!(6[zv>\#anv&o?t[ӕJ+8]}_}6 .Q/ vĜ;mn>)VD.pwbeo~ ({ˠ@PHM_w;J/Nu-z&4:Ln+W-t%>0ɉL s;jW Rk-tg`vLVpէǓ !1}a]MLEjwpW?KVyzHC5e5kwC&;zqx}(9)W\: L}1xs OXd|T4:rTj:\67Tvpt{jh @srKvUHýMwk$ ~ ({[].WyfZwUBezgy'>q#ϙQ exJZٿ -#4 <ūngmƹ1NMJ:oΚ<(O Yæ:'+N*<ٞ?o>U3E=u.vE:qK2x w,4dp]>)@pLOʶGbP9cw8SMBy^3>m=Nkh+"ߗAgdGٶarrؾ@ @9rA#zW Jmir}s9kzCzUgn" vd}⎮hWň_y0v .Oy-o{ϻL6jtqc OҎk5/NuMItF먣<N<N 'B q|ٲn4 ?xW?MW-g\@A ({PNb;u 2keZMϰ\Îkw=x_; 7K>l,G~mcY`]pYeI rrʇ_2e;*9 * @ r007#X~UT0A ({!Pޏ ^,;uϤUA'й?!ߞF{[%xD٠ PAmxbՋO&֤ m 1_::&b1|Zb)RSd΄A[{zbͿZb(((@ 弒\9wڏ{bDJ;(5hCmc"v>u5V9'rg48\^@~H\+P)Dkv1&4wjmX͍?[!o&ᢍ/Qy/oT{o)bSA-ݗO\[ >pT)&PQR/K,`|&.Ѷo}p #d݋@9`0,~1ݺSydCe1&8NI]Ş^FIu86OKJ̍Ӥmy_zm4O:.'8x xGETr;T_{$zW03J9{ۏ'|#<9}$%[8r&vAXgW_B) WY/Lf?cvR켯RϮw }' ۿ?c}tc \ג:^g(@h((Asp5c,OYl ;y1Нo,tltK,ɧw(/V״D{p,H[R nQ='PJz).C낆<~qIsE\M,Hʭv znŏECzw38q8(ȼiض cP>J?`[W0i7#f-"յ$л_^=[b \OԍJ3h ^5Hf+Se5ԄۢLୈ'~T[\ՖT񎠄\` *yPNg{nF@j[aaiwwQDɳicvz|ɁM? I NURƐ_qAGFg!5 dbfi/UIKC" "d PPN[VڤaA@9۩]e<^/_Ͼ[ނ*f1?+#CǾS'n2i6A <[nߪrvˬ~WЯ *W,]C5"ֽnesk$?^!VQ!nFe6YDs⇏|~΅'#'`X𗉩&o:,ea3\,~)#[f+{UaSA'_gd6~u]R7;1_Skt~Qp+= } uAV/aԝ6}Rn0.K-cVzEAzFn?d+ӬPۙ@";p/HZ.+ޕP`裠ܳ~[j/# MP= D‡[RϘE*tķZ1|?Ļ`!Go1*.Q/sb&wL½sd̽wfbhrh21˘#j\ EEAv{WYem\0穪sNt7-?ӧNoU}N\x).N,NTID!} 5{3DN6ew.-C酀<@+m32x-h}ׅ>:Cq(N:CN ?FG.ř|9_]>L1)7Q3fV^MyNI>WNPSPl\?Lo mN;h ^#-zy!DRa^#QIl MzePq7D $%U&e19']O/lUs^m9U*}Gg!=^QIiZUg3RsQ~72@9F=P7q0 GL\(юE(8]b>hPL9}s}byoLNЛ|uXWGWKR됄&qJszB"I+Uʃ>SVCN,h6SHZd #Cl:ov ~PNF\ags9*6J+2*8Ƥp9%* ;[,|̅X.=[<.Lkல6c ߣ 6v >gPozT0N[ʺ ۆ"xFXBzV)A9[B.ynH,v#7=3؆^ 3a@9ArV)th} d[Ɋ+vh6krQuq$Moq.=ɫ@..wJk<'.z&.6;uvʱQs|GG)o+]Jгɇ9h6?WGsƻB9[f\9o=ocq+&´Px~JJYׇeB\YX}ozSh rJ }0gȅv \9Igmbe~qћc(SF}^DAޤmи^" 7Z?w! (T#Ry'?U4O)[D3gq)hYw!]b\Bof3rqg׺Ӿy3wjk3֍\>Uru~|uo)n2bqA9}F =z3G59TˎsF:&G >efl}"+0 (\dk{O׺-!k/P5Ws`ؿL8`c϶eFgӌ׭g_c+m*R@[=ZUWY9VE'{._fy\Yn\<[XYDl.Ώܷ\7oo#I<7Hc }sZ*w~m׀}ZZ&s ŭ׃nW~AؠMmWV~NVY9r*؈%}93`s$%PY=sPw$xi[-szGni:#):k{X#ʓ߿{QdWzFôkZ&ń1 ߿q3ErvnO@hiw\*_9=7 ǂMԷH=YY>(ze IL|0n#yuM:z/>fda.|;A@3{RzBa27%dZk#P`o\;}[wu bQ9ߒ&לޢ}l'7^ {''6#q~gDz($םʸ2YP0 Àr+(rkW(+FA9w;-ԃc: M(r^ڹq"d/8urv*ag *(PPprʋO F}|4-MU|&qs ^}SmpB-q>rtn= dgn2Yfn8ȶwiw_vt\Tu+] 6)R7v#,ȸoU LʳX=ht9q4nKwڜۻSƚ>t8)( *2v#%zmrgr^lo\[ s-ZG4iz -la*o@>DcDN}Ms8]oj%ԍrTN~2`&w?볧DzHՒwhrg2{"?Wx;ۚdVu #6F9߆*?:x(psߘ,NH2K#}TIU(]FWdtQgw@2rULzpEs1 ڃ L,6Qt_DEC,?)/r?<ߒE[l!zw7> W=}Kpw4N8,g薓2瀘Qwp/Vb[U|lWt78@"=sCYDzO=O(m|ygz8Qh=oODܭ[&>+-l:;\gn <ɏ'rV;P~q_[v_JGcqm`e+=ybdnOe 0q!^*w?Ϳνȟ/#N3woc ߿0c;iβuj3ukw{;Xߤ1t1^.ɻ%[Ns֟k+g_љ>+Ag` ˏ% 7xk-u uCo9Sˋɂ,[\ ~ԱAؼ ( 9y8M /?o7BGijN}&vV;kn+.niҘ $_$omY@I@w;542W[< o?\4467h_kUO\hpKRh=,Bl:,)=̓k:Vg;UwmLAOL?`7x~nbgsEZuV+w_eY]y4ݤ h4V mƍ[mȟrB|MTan`Lܮ%/2 ڃ T}Op#}KpQ>xwT{n-.M[z)qZH=)(2qY/QT9V==%y oTRVS4g2Ov4ezEIci%@?i(_{ͽ\% *qYE_7unvgF~ܦ!Byc^ b]j;b&1Ǎ v+5O:Nz'~y!kvQ8}lA|K퐫̱ tߎ?S(سYѾAGvҮq6R8Ɠasq<.Fiu|&*qҼ+ iult7~sWwoT]r%G^*eCWKc!yw)4>ۋt>kIGg-sbyl|RdnsӸ7 Npt$6ϸT2?v H k}kr!WSGi9HA`F:/.c0=)$+ 'C՗G}FL:2*31YYۘowrDKk랍}0:GүoLXiPF}er]_g߭d_x\a~(gjp%#!GKB}o)}%DnNǘ^eYGL1vYNs9+wh ">_K˓'|?}=PNe`-A#eǘ<;MNA- yjtrNM.5ӼG[?i:̯3)v]x˰[^;՘NNWyX %:RfWfs14ͤьgͷY>AEM{GlV5V U#+A͟kw`ғJ_ЛΟ1,9 Y<[Ꝿ} G'hi&|:v>zIy9} ׬v|ӟ|rƼx[(CJ/@OoKiQ1)\l^'}^N(- ^2yiN -Ny?` 6^;fxDOrb. }rhWnx{7iO':$,*,Qziׅ CZ4Qr_7e?*Of0vVV/H,=6(:U؞+JT,tVq)7+ISZ^gJy45.M)2^_U-.jV.tr)cPZUarZR 6x&q`u+7LryvqiUp\r0o*b([;7vp[!8(_xwKz55Dw6Vi:z=!*f?WEk Oy.>vXOۮF7~w..O~%X%<~Ѱdݕk=3g7 1߱zF23#Njŋ+N-҄-G̓E$*7G/4jأ1vUGͅd]47g]UU`|2ժ/!Hh;m=Pԓyag50.,]#Ipfpz)--ı^rle|xc ,,8844Vs$e=w<`՚/WYcw=ʧ/=VM{GF.yG}͎$Q P9E<=SխlH*[\riX/iLi>\7QƝaԲ w>{H%Bxӝ玔gMuʓu tU s~},TTzd%خ⍜IA |OCPI u@<ߩc7%5Uu´ۏ.XXR9<șGrV|"H[k ] .\ l/|7wRɤ7l ߏ O2.4ge7{أaޘIf䅘]=(}֬9b=e. 6LE%-=q\N^NGMWV/YQ7v]}Wkev vr{ RE7qysLQN 3QIeX(xѫKF¨x3-X\LIG ;fja wpTYq<'"~ˏxwi0R۟NggnTQbj,+m%sN{կL__<_@ʟ0oK<\͇y@r&Y\pBwi쁿%BpHld"7xN{EЛ7ޠo4+GkA}`!:k@[P}f'C\@yOWwoqe =ַ+r?szϜjs e(;R>Sq n~Ek#箐Ϫ3}G#Jkm0 t{*P6>H "Hګk @E/Υ\pP-=FlC]вcvqUvqF'}GD`P:(VRU|v!,¶W-dkj)x$(\4?2JiAr3tRP8aQ!=99>.",/EE4s$=~%",Azv:$IY\Hyd;?;@I 'pTk;B#]|{ʠ8*{VHs(UJwju+ L7͸)g:lf~jzvxqg uV{N[Jvy%({u~N>< *ڟYg7¼S딾3WVlWWN^vO~HU9VgSL.,..f``77E(;|sCD\|{P}&PAa@yQjUޤW\3 iÍ,P ё/zFRk%!VM +c.JE7[~̡ uS,X>.u}w-/J?\|~~I[K-6f<-YX[DսvƑ'H_o-gRPA|0)4HOekp?l^z!_TϾoI|[{CC5fn!z\d0 G-}]Q5 9^c.XgU Ï¿4d1 9Pۀrw(aԏaaPAaP0 Àr0 aaPA/ o`#5aa0 0n۱ #vr/)[o!䊑v`raP( Ak^5]mW㇣>_C4ڣba7a-"E6 p0 0E.m+ p0 0 @9 ÀraC(aP(aa@9A @:-0 ÑP0 Àr[TI226b1>KKf|0a=b(mnumE]-*&Km ,=?R)-zei]Di\{l޽nHͶoe-Ow}aa (aa@9AOʥbp"C6c^EUw?VhK{e52Fw^~SwL?hii[]6k<ǫ.آbp:ݫ1GqWmO+L{4% (aa@9AO [h7#qn%֨DBS[kIKjsbNs quC6}-3k [_4 ++{~2ň%Tڢ}{bpU, G+uz[>ezE^k}I,|&ET^rl-?~Y,K.yj'n#1﹯&IO>Hlm]R*|m8n>:ukC4fE~Z; (aa@9A;Rnτ@(9ʹ4#pU$w QW=VŽb evEMV]qT*GuםMwPhosX D#ۺӰo1./Cg~ZSCbO4;[u%RBum+ntv[tܑQa3}w`'zp|SnYq-w-79&ꆍ04e$m՘);7 u) HfEr/{i>s?_0 0 ( 1CFGuRLkyԚZNܭ9f0Q`L-8-7aeNWwܤ"x[xxS?|6pⴴg. *YF^ *k0Fcd1fiRl*YeV9Cyޛgi5UALcn2ByMyKwa۠"Moмy2bM4;1,6T2]9}PaaPAУ>r=>)F]ZPo>v)m"(G8q|W 6E.yݦ/zu˕r-s`4B3 ۲N }rQB>>.9[W&/~4<] iC^l7Op{o_y@-*TH{)Lq }/ w'8o e1j3~͠\2FxWj0kߎO9n./kϢ' Y; Hz4tqXc{/W(7Ѻқ?JHo huTY 3^19\0(W5˺l b2fY nߞ3^>S{MEb9O\؍rCJm  !B^l>t7  9ۆym7(d+v¥;*+ Q1:{@.5~6kDje>Ӵ[#*s6 IgWxϓvpO3i8(y|AW7ݧh0>H2wWG]-<\9,% -Hym7{IJtǎE͞eywyc5|deQ?C#3s ej"x1ly;'iĠ4?ZذstM5bhGso4he;~ Cr.))!n]Sz2yo3" AA<樘SnbӲ ﾶ?y9 :^bԥaGOOLi=:)j/ZvOJ#ɬKU/ʙG @ (  o(wLkj֤)[t=ݶb4CϧG8J?ga7k$犯tLV՘8Pmî'm5~ltNMC1*&??=y[=fGk;k\<+kYT4Zb1mA^B={ ! 3Zyy\|ҧn}W6* 8'<>wEM3;t[pݸd7w5#5W'(P)i\u.o!ڊQKOʹyaNGE(n˶]e1 y"c:n!oYCF>.OΚn!mi6[ٍY(Pr_Ҝ0qn|)D~٩]9yg G)nׯJ`hH"Ng(!>s沍ܗ0q2t4//uy'iZn[+x,N;=-g۸ Cu@{isPʮ=yͣ4 |[0ZRwtΐ6.VUS~|)ɹ,͔*_Z1ufo)~#VG(Y۩ӭLK&1k:̴˶U|G W::>?c=]N@gmT>P9XfRev`@Y>ݱmoER@ @9AAcrMgi(,.%u5t^8 jڍ4Y sfuZzlΣ-;̞i'`nB%=玺nC2c| St%e.ݧgJSYjo%Ļ 5/*ȹ>߶ۅoǼ* GNm/Ӆ7~H?K]&_*ꍟįё#]&bI@ CA-Ő\dGⲓG~!O%}N@;\MAӞ)5ߗ(<-Ma0kWoBGj eZ}QG}K#G',x*hm.[*5 Bی\rBMpŜ< }$} ~?R8K7aԗ au}{n%T\&0}k!=(  zP5g+5<p8Έ8L=>kLlJpԲ w tBj9w% $#`+0'uSȔK$ڍ;] PPNArLHe^(@ȏܾ`mL]~.ݖYr[>+_UQY[m5m[}Qaڗl~LC85\ Gn#0PοnR-Me{Xa{iSĵF 7s'>Ay8[zDz;mmHds1&?>2)ƥDY- *W}3 !47m6]Y$^-nL*J6,FJL?栳,nH7a:Ϯ+4e!mo!@9AA2L"*mͿƣ?<>.Գg鶹K^c޹TUݝ-.RQȦgMh+og+ji.˷P|6 -F6Um۵N[HEGMёO}M 󙶻"OXL.Ksw ީܡyo݊q}ښfSս U}.)BYBg6[,W])2Ng~ok}'Dpk{?m{΁V#fB{ Y͗fO D]5F7\u[kST1-}Sﹶ_Ӆ7IؾeHAr 'Yaj7-*fDE~LrK qY8ϥ0[ĸuJR0q1tжsܔJa=Fw<y.ODI8\Cr 't1#0 Ñ ! {0 Ñ ! 0 !@9AA/{0 Ñ ! bHK.ᇳ<4(EpX|)`(  Z\(? x0{#j>Y>MoO)YyV AA%4{|; Sz_ɷ ^)hw+[4.E-˗{t?C;tO-=:MHҚ+X9{æn *nUM\(_4v浭.rJMh1^>n˰ܮ侣ƿ[uzIaB7u7/.n|BMߊ+o6ָS_o=RaVɈ2TOI&uŕQ)d[SZ{#`]zV%Es[Vm ߮,|wϝFœ~2W<+(L̅4v_]ZiڄF&}we^)CA=Ci|n-9uKq |_܎~ CEiwUZy[)7o,KSJXdk'zRTh~`@c^!Pv1ji -_D^r7fg}]  8G'7^ҿcɍUzEܚ4?G[]jTIop禤P+SfR(DPLqKвFnLYB7][uK#WoE1|i+;/oIfU_֤:eCr.)K3)$yxɪiW囔FX;_) Snи@Gїi:ptujE Ն.l-< >],w}T-=C#SЏ741Zs}4ܡ)Ta'yo~Ho,BtX]c`[qxNt)PAAPn'겚A?) <=qʦлeU.>>-aGd' t#8_0'$P)2Ddp4ں+KFakM~A<<눙o2P]SY l;KܤVf JL?(̴2ȷ;dY~=B~c-$(^RjwqY 1k쓲%CnFi>"[x>ORnV7Z͂dR7_z:'FzwV \jXBPUɀ@넢1RoVzeu*f>MjPޡ>7^H,fv`erUOi瀢[Q-)t;'#m!Xjwnv?WmbI51Y]UimpHAr ʧeU7YOծRwset52 $ X%`ZcPn2hY.B\wAIG) c XwwYZW|A^(Km.uDVԭa KQN3\[lO[иm\uY_Oy4!ʐϗ䖝̷?+/VѸJMRejf@zm@곦k+dy{̟;z焙㹄B>0]vIGEߕ4k74 E/?9\ҥU.F_3P筀rPAAr|n- q őrr<%mw2s(,l.7H[hz&N<ĤQFp`>O|}JϫdH*W?-U]lRP-aŽӲ75WXjg;VeSuX*]8$ݡV؈m-o9'wӲl#It|>Ki>i_%I_['W}HTLW.\;VWKzt~;B*. iI]MDcؗR  h/"{>wPwK&V #bL~icU;Z%C?n )$*p;Ҁ;;%IuxO'#eDX<Y3gOh _K9?N=훍#QKg.ʇe *6ͻhB*L 1\)\bnqdU*zk)@t۹=j}e]~>H?PKR[X+/؀t"[ƬUY.lz.!~OHl4X#I/'Hҭ(*iҬ^?jPXR;1J#ңI{t;Gmuz%k:}n,t<%. }yX_>|(K&P˦gpu]a)\]ǤyY+1|qYHV{1(=)0[D @9AABd~J;B2(Tk_R?uN)=%YR\5;y i`* nWlKBr)=JCښnG@GvZoywxR3 y%gAO>;1!S-/|3ӺiWrho{O]l|6fL7[gJToH2> q^bRxd$ؙ`^4$?K x, bO3%N;f}<.T ExFmZ7A[q{ݾJ( NϯOnu(JSYۅ1@ CA=v(-ߒ맂4;8e}uZC7$ V?j9ؾ1']3)>]q 1=SܤsܔDj=Fw4dm $͓4\   0 )PAAP~G0R  P0CAaC  P0CAaC  P0CAaC  P0CAaC  P0 (AAr  P0 (AAr  P0 ! 0 !@9AAa@9! 0 !@9AAa@9! 0 !@9AAa@9! 0 !@9AAa@9(  0 !@9AAa@9(  0 !@9AAa@9(  0 (HAr  @9 ÀrPAA(aPAr  @9 ÀrPAA(aPAr  @9 ÀrPAA(aPAr  @9 ÀrPAA(aP! 0 ÀrPAA(aP! 0 ÀrPAA(aP! / ;o~P<-~pAArI'sQB9 f<2* 3Wy%G;"AArf9 ( @9AA?n9v3|\LË9=Ar z|bb> 0d' =PAr/0 OƸ~ \!@9=P>N. a'b\?A.-Ccq!W9rO߃aqA{P>J!==eƥ3Þ=PAr/߅aqA  qMաڹ.;1KLIRDF?pժ$U)~.1)L2dWBo5MV|E! 0d'Ŝw|`k3ЦHGX%Z}W>&ۉ%#FD@UqB=_ݜEZ½O[g?w/0_v>LGvgrx="iGUj,V))m\cEW6˜)ꑬqfz8K^@7sQsފFn^?>PA{a8{ۮfϵr }t{`{=d]IמsoѦ~ڌQ4]?tpRNoY>?ir޾5d޾r+K i\һU;}wGۆnYI_̋IRV0O1k'n,[R!Y>{'DPmKY4[|-AVAWh>!;`.*?CݘbA<3۸{#\CzQC#GΘܑº;/N %ilc#οYygq9=M±fh^F䞸oŽ@놣3o7 OgKεLKremt»˷+)Ho6g=odh));%R^bYMyKQC R5G {?pA~P΍H;L$gupoVq[R6Z=g8"i*U\E(7SKsT!Pr sOϔӑ˵!3Y WE{g;RS Ow3 o6|$Gwu AVYQpׯx(n][Bx6Erwsu:љ? ^ s Z};09eKn̩{vjw \#x|ޠe Zfi{Gl\?AYC%tP ( @90(`L`IԵgz@ZΩ}R3myXZT`cm7_ s|W6Rxݮ{o L[ iq^8;(߰1%gnG&fƬn{cMPC@ Q.o䞛a`ᶿU=\(xUjzvUw\@^TUUdX[>Rsc`,W7Ӧ1DL9pyY(oR||P$H?g $r@4U:A{jɾgsT1~u/K鷵??J/[tn=ǟ4R'cw:{/@ A  :r3@ hm'H AAΡdA 6$H TB AZPnzl Z $H*!~ s(@ ڨE41'H AKn D @9{'!E2Ⱦ?Z\oX@ 6(wA JP@ rH@`=@G0HXGPn0@ hm[H Z?A@9!=G7@ h  酖funjazc\pP@ uiI\oI+?:lnܦڔMXYh?z[>b[:tB6T.+H}sV2q~n6Zf[/+-ǁ9 aA ƌ7O|S0ݏkcͽ6[aZ6Ahdm>L۪J3ksfX:1@k\ԇe棨9֎YŊd3֔uTnkb]AGpP@ u#fa9kLdZۮm7gfa=;Y7Ou cޙ]Ljlۙ/R+/PܰAݹ)8@ * ]d}tn`QԌ mp}InN6 Ua i_mOj5xT_3cSW`V)㴃%w^r'ǽiNo;bS9*[jޑ4{Bb_Wmy9+[nz]D7Ohq9!]l55k֖suZ1Ue?[ liӄde 8-ȡ܅i Z7A@Mf\Jf@ՖWT\n \_NJnje'PuK ^RfJ+L\w}ge[9HSKeqqP a*|*g=,?y4=vMH%6 ꦴx8-O|iƄ.NqY}2l8&yh$7IX|#e˭y߀R y@ ۉѐrZ] pb{㍘ئF12w` zQL#Wޮ @9_@嚜,ٯߏ~GNlNJ<۲23RY; O藓DCxvmI<޼Gݛ{#f>o #wCo S'\/]}Smvl(<Ʀ3Rz03e: bY쑅}JիcD83D!1[̿閏"T~Lr=W'.SFS ۭ*^A:ld-odvU3m%&F *1ҷw+MFL&3|~`õ  A) f?mŔ9{eW#TAyn;;@]N"#ks% ]x˛ڷm=@7t#Q U|J^~^9|t󇃞Wpپz:71P~f!zIgqv4!($?2s~4\p2#+hjQrs dv`[ay -w*چk|.AyXs||Ut J},Y2c[,'`>ƒq>By~?/υY mש`07gSOxk0=_ʏSqy?NT!=3(7O.'I3[ȷ}Ljg+edq7¶dS(?Zg2yq2͸L~S5gCl;^z6L1%7 5ˌle4y ʿᎧlXNfna ,I;K@\ը3ߖ!BNeK90AϞ{3&#vH鍣eA^׃~W5װ@2>,4uJ㖝}3qҎCCh㘥updA1Y]u+7 &Bz(;K3s+YK1<ҢcޒY(= ;2@vѕLBg`9ww?9>S=E7 ?:7`.׮+g|9t~hMuɑOdՠI*b`NUrvy.l[FNn90ag1rsAkK|6*F~0 K)bƦ:zH)p6՜OÀ)F@zˤW/2t/sNAZ~#XOI2=Fjա!P>_;_2l}h,Uʳ-)>8E.)7EERRoO9MDAʓzFjIvO;ķɍc1@vŌH&1`]UdR 8-$r ]W ̺\CGźP2_cXH?D0l)ms%w暅{Ps3;1xSPLS`V>l.ٱ5䌼b?rMe֝t{59):V|A8]F\w1&qke8.IcEnxx@hOV@Q8z}$EG=N]Sķժ_Fy[nV>0/*%#޼l_[D6~֕\ΰ/0A⸓N?o:|-vY`gkoUvr٘-gǖw)|O]A\o!E|vCǜ3~yV(^mNi&Ҩ#gAy>Ukm@9In T.zA@y8:aNRsf[W֮Jf $8O#]|b;:)*G:aB?)+PEi,~#cб bfu-39]3r7| Vyzoonl Ѭslӗ(x U1X&ef}83KC Pk!w Z  ʵ&*QS/}u3`$g2DQ) @吞:{:\.tmk֮9v y\o!EN4HL Pm9]q~y|p<#>y5H!ξ#mfc,|c,eFB|K>;g~Zc a@qR @\o!E|sLN@ϓ,&Ԑ6exsyj^|؎Q6.r,lQ\\ ʇ@ 6-$r!@ @@k#Bz (L@ h A 6jz @ ZLRl;@ h Sjz q@#$@ @9Z\T@ hm[HCg@G0HXOP>@ "` @G0HX?PBBz׸RS 5.[H_A ~.Aº)W4bQ+HᩐN*WZzdW_7V^FY)=];]/Tz\{4r#ObO>T&y  A G0HXGP>kA ԥ!URSSl۽)ʵ+JuKƕXBT{Py;ϥ(ӦpFџSwx.EV^O`paSGKq!$q灦A۔y  g8֏`~\9:)_NF;&"C]7*o0ygWL/G{m+w\=uA"y%]*/4\R\?mD#,:7 /|vA`Xp؋代iv?C\L牤@ϳz @ʧdˉ\NnÿncWS jL|1AO*vՍ̑ԎBdxtHS,QG.~Y햡f+ݣ6-Vc(^O92 >>6Ocw=B|R6o$RGӛYkv6Tz[H_h@#$(WAr()UvAn'4mvem&wV@x10k%u6 l"7͟EPVXiD7He Y|'Ǘs#|Ћn9]&)7J`c5 _TN!H}b_*o8`[{[Z+M"+C}t(vne{o>昂󕜎1t(W`@ e_98~jSՒ6@mz*0қٵ×6B1&:Ohrm .=T[Ī "C@/z )r(A aǚo܆_/b@ Aº),'nSnlJj 0>&ǹRY^J%I)I%KO7Y)JR=Q cN(: ᔉn/ѢcZ^`x\*ozp6HA-@[:spBGX2?eKLߕ9f<,IF? `_>gnvݢ\6ITX%v`<]$_,rA2#NJbHݜbقqB;N{Pޥ&h(Ol+6 gSd>G\o!*k Y[>z kJ6t^Kb3=O)=O/f6h3M<dsWު^yǧ_=͟?5(Gp䅠Q3wm2X!ŠZ03|vTpt߉iJZkop%@9X wwu.[KPSu,W?xG24Kn$${^ۙe23PCF}_[ɛf _l[25)%gN/B._wRomrIe7i ҈`E}xsH)>~}a*z'$urϲU@Fͱ+s*&oe@?|tyܦv60tb44=>#Ꞝv׶ ϟdQ$ݝGsm~(ix<خ+{hQM/* gBui_2udPPA24(\1q)~2ijWl᪗U=vчGhӏ+#^8GlAN,Xx*bҳ{ \o!=;PW9C5=y,uQksAIN'm't’*~83G@:uzۮw:S}U ۚ>'qCfaY߶F׈Br;6ǣ ʣl#`xT0\)emț,i'3u볘MΚ‚ / htƽ uoml7WJ;Lj:${cO-f)eI~Ŀ-9ECqi7PYOd1G  |Ő3ihJTa*h|>ɍ}| |hM?C!3х~s$_*o2> @ 6-&?oқJYzb@õ dJ9R(!҉!)^<U?{is;mMg\nm*ф/@ ?`OjDp»?JHki07N4?̌rlv̖3>nDi?jvm+ӭSCvU-gAX(?::3;P((\)@ hm[HCXN k:!8W1~e0ڌ.r߶B(r NhscytT$uȢvk ].r)QGf(/<+sv"=쒺tfyVugkr.V_k ^z_XP, jy򷇑Bt:NI?{jԭ{N+OulB9W͑L\8iyZ1Cugʻê'+9)q5{79F //َ(6Go5`p;4J8yMO j2y:Ӌ/>"Pi q\m4ǖJu8~JY#y)|F@IA}[c eũ)!.s(oMOgzMa /Ro%|r%hP@\o!>{gT9}[|A3gtݜoӄdV3VHun s]5x6Aº)? uGϪ>6Vv%SJ4̝eOAk9G&'޽2W?"l"ʻU6RZu$Ǎk\qJ11ѳm7'0MYw "1Jk0iO <+/(TTϼjD|bP?Mcy\o!="菶O |'ߋ3`~\ˉ(z{wŎ6.W3F+u?9+s3ߞ۞.9/:2b8V*h_=h<5UM+6%lMئT?C=r=NN=~PŻ,WSOMAm&]7Nj+C؎OIq(s:[[E۶d^8pkCc6ּiˬwsmy9˸h|o~7q.fTBiF~L+.xD hB!\6)+y21cn[NxF/Pi} z+s M.#_* nNim wxʻ'+;ĮL傯~ c^?R% I̴_~}pz1L[^'GŻʿߣOݑ^[H_hBJ?4yg|p m`6*6/տ.f (" a]A9o94^hLH\腄$JIUM5tdN<V@^\˱=񰉷 7l 2Ӯhq{͂z^^>e"hPCaym* oSVN7տ kHN=$]ۓto#@+ۓty½h2VAܥNMIi%(ˬ5!Al2۝!|XC zlj@~_yA,*ና.Q t/){%r2ɻ{̀bRy)SCbxy[򏱘I`/䓋y4&PWkӤ6~[d/i2m 'Byß:O8|%?Hſ;"_7gJE KϛY%׈O_C,a'kȻEj2#5F1Y8?~z\;ӿSa-osT *O=I]kjkU4ޯ)kMF~U3PcQJ^*9$I}}oiC#Seߡ7P./1ڰ+Epˇr/Yhxz*0<ܕm ވm7,n{#fa( uYWj[߹(jAգ>'Sq1poκrPi!P㋶?*1hz"*3{)zw=WDQ-;7vo9~_4-^Y W9 9QpyͅY2ol4}ͿvUM;݃ApXFETy$~(ٹp'sD/ۼ !.XEôJaKл2 Wji%opLp1툀~vBjk`~d5b~;Wٰ Nذ;A3'3r{ |N2TB4έyhJA@ *׽vyz&bLj3ỹ o{9n$0 ..:!}g "`;֏`\˨dCImKh>RxphٹGwtu9o[Uv /y.V amE xf7Wd s2{Ȝ]]r9LLH5lj9RrI sv"0Dʥwd7H?DŽ>'yS.; x?]i[ޡs2`7v,ʅ6Àt|El%, =ێ xFNnAFM(CҪk*L}@v΃j@r^M=bW8)}w7%~3E΃nܾ1 7mM; S,T"U˅-Rk139xE/ox#=/Qp\/?[eu~v5}RRqu x".T o~M+:-MBږ*/}1GUгؿ|hb1'1ֆoy99YMRl^6\?L@y>gf1^qT | }=?K$L9jߠ(Jm6 OIՊyp l_;{'d‚,(W)G~-/F=l+V|qIR=,w9*{GthWact2F7CSΣTmI`ß0k]ߵgOLzV89lu%m· G1qW[CIiWZgzƞ7@E0HXWP^Nh.`ާd_v5m:Α*e}tA;I࿜|:|}-$fG3٦_]ŀ>c`g@'0m';۾AtQpĔoz4 '>^* h'O/3&kzcMoKF `W\7 C[Rvo@elw3^,ug*8e_uW1l*U.g cT'3zEЎTtJ=7IffVBڟ gk]qW~mczNHQ>frX^Uώw>yS&%ks׫W/}&}QDya~_O-g\3g)ۄ`ܶA셇ֱP^p4طGUOPm]<_@ySnkK}dqqvq,jLJ8Olv%S}^>ڂ-ǁri*RV C m&{|lQ=<~.WYdgmN2KwKڐ+Uنnk#X\ʱz;?]#(!k+c)߅XCyv[_=(YǏ{p-xc$ ;U&cnk7S{={w[ -lgP]/gKuM1+/;c;QF>C(@ @9500G$(:f=2ApNgG5W{ׄ+{-O؞Q=z =_-'?j8Ć#]zJjML:RbsϯnԌBHCy]bIc=Ox|9W%v}t[kʍRj4cMA[1k7_ sh  (PdPnFgs.CR,7*tAPb DŽrM`獺*ZE/^@( >_c/?-60 ^EP Dǻݛs̔˂sNI#PzFݙlǘ{#kpܤY`F暆1|>O [:5vcO:2_j=dšs@^ݼ;|P~?lPrCzzDz*Z '֎Lh4lvx`A2^=r`?{\.Z52˷d{a1 ri vVf9gg#[cىxG֓%{-|Z.)#R:T/n ]x󧳜.&nmbuyYj ИƸ->?V*W5`q݃-AگD(No)]JƎmr{mTJlgLĄ \^rgP[ ݙqY:+ֱ`Pzz/]@ rHkbC [db€0rcN/|i e)9{fO=_m\$9K(PnAX!E:4dnW~ܥ_p}(Ck 5s_BmV*tTΕz5}&: Zzkt!wmwN΅<}]nR̴94Gs76OƖ_m깍oC{0?吞S(k+kVt0@ rH/,wW `|O2 |MK³O6/B!a/@&i>%:fl؞)^rBMW[0h#}kk0P!^)gTp[o>şXEkxN]z1-{Q3[s{֍-~uױcʜS.g̔k0p.?W$rz}R˃an%yIOa|7#NRՂ|4eD7gel !u;T6?]<$q?KݹLb^"(FUJBj>@nxMdz)B7Wu]mp{sc8LsQ9}.sLCzN@~P~Cf ~M߫;Sq:fvгma_'lVYp윾j>W^1$ܲel_l 1 <v ]|ewח ,`bH`Ia(_-o@a @).L/TqA_S j9=SL[9fno[_̔XnߴA&7Zrϓ>+lidϔ/Ò}7ʻ5]mxA3_i?GU 휇H-uƄ󿛮P:8z/!/KOQo^[vtFWjfux! OgVvYzp/dQG>۰@1y|:;!A `,֏`P8Pz"|B[ajA5-_£fV*dPyn:Xzg ,3˷TuGb@q|pj8ɱ1 d\ R`;N2y5m0o~s|P[dz6yî..`Xc`}'gPHf*(? +| ek * gWV`{*f>֠]ğ;a/B}l JKcdj9KL&ʣ/X|\I$fR@\Gf7+=p9x6~S}/zGfjf1lM}T̀)ڥw|ƍ9ߤ3<˹m@ /{}_m ^>Etqr/Q;A'̪< j3Y@8.myh%^Rzoyf%\IfzF>d|Eo~ )wZrzYj8}<;ʿ_9b 0jH!&}dOpw(0!JzFyv;6R׊^*yVj]z1(ǠtkO,`ycž_P.a1`o[=nOroc Nד.jYA4oؙkR3qM5dYEl}il0_^iq햧_P,aD"P~gI(_MYM҈߾<# z\2}οSxw6O%gϭ"0Ϩw˽1͸Z1AHb+LCzN4kAՉL& k^ԣ +rΛ/Pn)Kj5 RP&4}m6ZiKQٹb6 ۵Op3 Cy ߽3ڥ1qy.\ՑOhpPNr((r -`}%@x:4̙0oo,qgDŒOlw;tp,^NO,n;IZ^ү.,'q3siv;*Ϸxkk~[W\%\M3gcf8,c{2>旯 (nwHޜϼ<^{eLC9Z%"\ ,gkMo1/>`P)q~_1T.Uf}R's׫W/}<f4@9njwRZ3fUWl7apɍ_#M[t6Q8Vכ?s.E(o{䉡v>2`NvM{>?!z/QZ\$`qV{ݸ{9gX/Bm^OI< `Қ@cX5$c(uS5ѕvΧ2#nrOqڜD]i˽׊d*cBz]!:T't6՛1)M ʛ fqS)Y (ߎXP6Ct;cZ*3^Dyhp~ĸ̄ӄq `ʼ$2MLs{/p ZKx1 '˥V!k4Go6gd8H:MM'4[v\>{`BvDE@vj_^` @吞Kt+/GN1rbr {.%7 17r E)'\-bO"(>*S1eoXqyvH=K;4&FoU!KP1xz.CG]h080a;Zd+Tv{1xqu7Υp1Fj[:xFg3s-x6:GudY޴g(F`+V6Fl(rpus@>ΟoaU .$@ / ʕBnfvZ%ip߼d(A&?Vݢ~u|CUiBWu-PkCt0qR ԆwFl :Wf9B((  O-1{`|A捱rc-yWlK v & @9$rCz\#4|Nfou|ur;ޏS6 6-^(6/Gl7stx[ey@ByLaɇ&#K"v{/Cg{@z!7OҳKFgodq r1OllY#:AcQ~3vhLZN7$^W3d|< )Ou8L^(OƏ  @吞(Я\%tuoih*ʎAPP^@DJc@J]g)\ N6JVJ%#]<~ћ cߎO 'uXL!ly3#.}Gy%l>h  (Kr @ڒ;/ [1}^0p0w _n] ##bb a.}Q 5aw?WU!џ3 dfOy<,ٲpt7}oH7rfy̙@r&9B&,Y,Lbf3`bblWy ˖}Wk,"[D^VK L|UwU%קev-xns{n rY/xˋCnfIO6?Ӹg(G/NΥx@ ((@ @9ؚU4TFLcOFÐSc}l򇜦HZ/.Dab7.#DGZOI@9N:7iS:?@ LA PVʧTQ-lWwIez$@`k Z?I@9A PA 4#yG!& r0r@/ID?e@ L@k^ԿeJ@_@9wz0J@>%`((@ @9+``kيq9c0100_D&h Z?([@`~5i@  @9Zrs000rD 0(@ @9@9 ZAu/y@$~kV>ˍ"ш ?u;ѵ ZS({P>nZ>@$/[7c|Gx|\?%9LnA    @#X(@ @9-X[,0000rh(Y3  ```ʧM Z?/@9%^P@ rr0hK00000rA[r2^aw˾bAY$2c PW.0yZ v]9dkuj}Ax(7Os }bv(QqcYJ)>;/z.^}77|V2ͣE*PG3L /Kr`Ж`````($~҄ @e{3v9ʣ|;H2ßWlūrbp]3Zx<+wS%n6ʭ}WiHX#QqtM4^ nݘq7kZLw\ h?o*_` ([s91Lcޠ(ϼLѶunv.#}}p 1-^y(o'WLqIB0^^U(w9ox㞶S.S V=w|g 2^\ޑ=Br3-+Vb/rCxlЈ1 Au0@$o ${xK8wZy[WCh!09BY\P+Tj(~Ɇob ~QjQ tͧ~8:_8X91"HBb@0(o3< (x[ <a9'*0a謥V٭tJ8T~bC6rRP1rIZKbY$^"UurŻʤ0ϔ7T= )?_k zÏxz[3Y~[ ;0`k!Ex&. !ˌ/UpmF\q[U;I"7nx xڣR*%>!- -ZVҊW|KFVf)D$q%a;4V6 7"N T< cwd? |Rz0>g}fpT"lW?aLkh*-Mc<ȁA[\<ޝVR<2Dž-r9qroTEP&0!;颛|l~?F 2SÁU~ \-[)Ƈ@(/gçSՙ+՘<qʆ[ֱA-'oV=Ź90l>>5 @)r000r14i@U@9@92d֩l/|ۘNf NeBʫEnk$-A PccS@ h5P.\҆}' m1 Fޖ"jKsR +I}Q FՓ}mׯf( km;4XtR{u/}=_.t֨謥ED=2 ]K jo햵 ]ӪIX- ?@@9@9)*.Bm,JU[Qi*P~1?jKA;!n(6)yG`2j"hC[bx(jw2b[nmyzQߵѤѾ0?bXrE',[ vE, ;jjMo>ndjR_JwP{OpAw(2'o7VsCN%&u}+PO ^wOUu6|Z<)]CQiMߝkۻ :3ΗLt PH(I3٫L69Ǔ'Ϊ:3<֩:cjKWXW6|z*xFh(=Kћ9|;% mO tZǐ!r(wi#ܰtEE}zZGRAeCl7K? .6mnYtGO c_k8PKM}y|dM)|?]7k剭=*}x˭(0(?7~Y IdBnqk ~t4pCh(O#EЄ}$ryRF0dm1O]]tO]v30zč5@ (GOHv<&yWk&n{Qy^oڍ}{a645cMVg:ƌAI$(_ߏѩiZM(քf>)K<=}9Wp2޽SKم&WCVkѶɆzBCByc?Q݊Wkwܭ9ፓR[# kd>T~ጋr5$T&7:r@+5 3 n0`0(Qies&۰d^ չ4}:E@.|}RҍmI-\4'x볐/.Ə Lk:u;n{P~VcRH>['4aTG8ѢF$q}ۈw %_rX+DzROw78yq}BoaGYi.-ye1ivMO׍ͷnLWS|%J?~p5߼'b_,i!eO:;f _ͫ)Uj}h`k:3.;.=rO\ǧ G^] ( jp*EN{̹ҹcmIGC1xڍh\+eI5LyӒ R%u0D)k NŢŽoÚʣYqޡI:pnϷO%(p!fsnJY>!^̑C̪O 7~ԵQ+X]T͹i@^cOiil%7ȘΨ1Ջl*ԇacsľNԘOch][vf[Gʆ{ 曌ߥߵ~VaXr:옡tKyմRP>&̠+kW qǃfKӭV|%ґ{-@r`A9WW```ʝSpm-c($%o<=Ȝ;&Q?z$?w.NaGٴVX`򵫿[hls|^"hr U平rbTȽՋ>V>1>БrVPauc45woܷGQ+v==*muϐVgr++˞z2۰^)O9:wQlǿ=Pl5G?VWHRg/^!7>%fp[=U %O,op>d:Ox-dZuz$LܮU_8>&YmPb_B1a?:1=._]mu'~`fUc}'S>=8)I4׷edzmv̠:cH-UӊA$htU|ѥDvtI8w|هjfLouyxdjx6y/oXtޚ{~>u)й߼sf`:Y7>I̟q͂>S q2Ήjf)[g2{)?_kN?s#ϩoR((م\|FO ^tUG,(\M>SJzxmkSoC#\I2NJ\ rHTB:-)?gTI6,ӥeD^Qcj _Ԍt!no&z+?[It7aQ3YפGC~}.ZL&4VA@ ;$𢘵2Tr dzrz%Wď\d=bmVͩ^}B+W^\U=6˭Isy)͢F6C?>[fkAz.^d;m}YL\`&n+i֔oM7d͕;#FP;fHH(_ߏ ڕIwnH7!鞌u4s癭ڞu\;7CP?ɽBӁK?;bn(kf|qY)?y%S&\9 ߺas/+!k)+5ү4)WG```hF-N7ߟ>7<ȅ?¬P`pŭٽ.sg|uI}Ӄ_yZ,j06k(?2pӕ] ܺK]'hiֳn90$ԓ[ #{SrNZ\OVޭ7VPx \eǹ]V6x?-`qs,Fǐ.Ls+lQzչW2v>VLtKredNQE'KGO@\!iՄ>՟VOewTl֐oo9ivקG'ƴZ9L[ 3t f-k Z2&=}jcU@qo:'N޻5{SR(|QNZgd'|5(_wkdߧ0I{8S^<[ wOp96fd9wN|CY_-x{fE @9rǴj%2*lPVV^ZlX5catpa2UiժUU6~hp hy`y}"X{JFmΙI yI"dHkѷP xB|_:^+m| /^Xz Z)(w 3h4qDڧ{~zM>\Ƃrsb:X@+g}-GW {?sn̋oA9'~ґ"7ۏ{OXO ޯɴiw_!@/XUxBօJsh$*u| ׾;:1IP@=oيA8h/qs*a>kv%?aƛk:&'\7`17[uCW>yW8tOʗZuLԴL$^yoQ/Tj7%}sQ+/{n_Q @9@9`~ףyY>z% =NR| !FfYm\Jviu1849Z2˨_xaML3_ W;>@ Bve|伙O0]<|FCy*=6hSzcmQĻ;ܞ+F}\Lz>0ʗWEV3z?ya{O2-z[8t>s;9Yƫ$r000rkmnV*q牴`2]_)Թy:@{@!bX)r'bgMBe¦(Kh/?Yp\ Ó ([PAdּPQGsZnvkW7B}yIP^X-7 I\ڜ5ۻj>+xz{I2z/l+TWE6cD3Z\Sŕd94e4LmP^|?^\ϝqm<=St7Ϥ^ZA(@@9zrȣM7q-NޣiqjΙuDkpiW7B 5]CVStVg#7BW)Wq!4`(ϙ.:IBu _!EكV jBqCc Zsx$-(=_6 ,;BX@}%T;t뢢}ˈWצsŎclT7mռqbRP>& ([PnCTXF'R^y;9̸j{):~dL _t?8AlX= tN.J9 SCPKlҐy#6P+ӳ?PGeo<5k5ǟB鮔kmͨ Y?~1FW~nAh>EJ\εD48_?(ȲƬoNPr60a2OsDU6kOnXPii(ۊPmcF?ql?k˨5揟dN*" oY:Ŏ]"ۋCXTvMfh'|BOqrJ4p^C>~'edY&}ܙk6.，xdg֋O׸7?GQeNܪ7i!?Ư <*RޒN)#^|URP?<9 @)r00pՐS:bWD;{o'LZX"(?;[+''fťӃx"\m`wr>joXUJup!Ei%S~@,(zǙmn5>uǼ9~HN!PWhLrRk]רsDϖVk*6,U|͗9rM2Dړ%sh*їiWU5Q}iQ=+1bCcxzw@QymoN~a4(ϹWhbzkLC7t1s|Z혘Ʒq_[ H)a7y=!T۬H 9u>s?ki`1 u;xV"l'Iir]B'RM'l͊@AwN=s7nNچGO.ک3qI!cXiw^VȾa90 :v? g0I?4lv/ Pn2LA9j )>:w\/j{umVƆ4_ a2PU~d1& ;nN G\ezl̹! 9OB!yQ#T)Oť 2΀ Ay w^eO;YNycȊKY:$pr .yέBW:X!RY7.97#;//^EgOEŴ1ԍ-N蛃ԍ yc]s ;MWu`c5q<ߏ>4a@@9ؾno]U02<>V7!JGg4Yփ3gE뤚L$5oe'_ƾ\M.e42Eou.2MY\adyE}+oeG"LjPS+R+*}Ir ~?8_OF'2LjKO]_}00i%2 3Im#*EEVMz5_M)S$!cJ׷ɭwB̨!+AuR&V؈Lqd|6+Rǹ>˯sA#kMVTfPrO{/Z Kv?3H{J4>iyY֭fAuM1к=f>W]=4_V ʝAZM({@>z̨ MiBT&VU~I(oGZ&ν1i@WOEB[57eJOݔ(zRϯ*&=$$ͳI}䪢bMمy}9] |RV;~׬E&$[c(疗wxǮR1*荲/I(;}R3rU3h֧BM=吘ei1C +qXqΤ G;.u*UIyU"m%.۪ȸ"/gnJ琳i 6+RYfp'X7 T ]Ev#(0Ev,7\bZ-gCy}eŋz!wm@%m1pYaVR {;ƙ~ڶ S`;{Ugk867c PPȧ}?!X#ш,^d7tnj}<":=dE-WDǵkY:5q.|u+~OR2>q˹A`n0qқߗu;/+^K؝m6T 㤴ɶkS+ jyۧJNH<܄G9 ]atC2!P9Tys.tNWG#rQLE:O{| {Uv .tc4( jBRJ2y|3OHHӈ~{x|^V0#^Ry X)Ug^2x—(@J```mhm)xe=! k7~]PiL&)^>s^|[xFOK͋JAcp@)r000rhkBZr(_l.iƵ&KiPڪ~V,KVJh_|;x+ȯeܬL@ j  l}@uJ@r;0@ j  l]@M@ ~rP>@@9@9C N9~;]ס1bŶ Ɍ qXS([/P.@ ъAy}%Uy؆]+dߌ)C&uVa{ѭʡV#Tw嶁/cOӿR v~:yLRd?Wpڸ/1O;_0J?r7|pڴ|ܘor&'fW:QR+9v@ h;V\vt8^{w90) %GV#lZ竵Q:~3*:\2dy pɐe i.'* msc?}^?R+y#?b#gOoݰrXQS}zKl~ec @@O+)[8<ǛSg?7An:[*s?:w[C^?o)iA`_&eύv!t|g_7=^v4SqŮSeܾ:>Bu {K;P.\a@ JA5i 'e{9 .)im? F%[\2rf,9~ǢZdd+}ޤ($_OL`&y-Ne?{G>h<;3Xб`a٧WCvn:ҟ-Ef \w kCHUjm < |qꫝ$+\*;Y͋nl0+l򕓤98|%W^幜4nl9Ǜ>>QotaEߥ{?z8ųi+6zv`Y9j{v {Pko_- yim66om&klr# +6>J#E~~v옛eɘU÷>`-)xhtC<{=dyiZV>V0|ˁ K; ]v(wk`ĿWP1o9~紤m/gc+r004I@ кы㾇 0$`z0䙖N[|6 5 7l2!c(8Pׇr;;K_au!)'M:̽Nghid|Yy,B]e} J+[2"'##. Ey"Uٹ~yR=V#+]n5W&f&"PecļCc8_c_9*Gkvog%ٳɸX+e ݌!^E)ހMe Tq,fܛC֤"~(^ܺE,JU 7[B+Que7՝ {5Q8dnyt_cu߰$X!U1RmNn&N[$rˉtD(r00" I^d[aۙ,r3_Z+i vpy]Ez/'y.;wZ\_T:T:1[8{̏klMX8`>Gse~k22Jgj2^w|+TWlgH"RZD-}&vS'˫{l)X]ku!cXvrmm4l>IBt8X1ǔ1|bh;pɾ,|ď@>ABA}D֑Dt8.[.>RqhC-ڗ4P~0߯ǡڋ[w P? 6fUbW/\9 ?v"@9@9Є[I[nzX$"&~q\zyD70*qz)J/(ʧM$o+[foh탦c< :WA"Qiccsu&43FE ,  M*>h"s|rݰvSzrphMW@Ǩ-dLkj)+$CNlë yTWzaCH(S9v3͋+TIe&w1*.U(EbKn~ PŭM$31W1TBH+/jncgt;i?ȘX .r00ur4A aѭ c:KWwK4*hYщ3<`5“AJ$I{ӫoIΓRY滳 }ܿ C v䯵YL%'7ˍ/6櫨Xc*tNӒv-kp .Vo}y5揇Mxޞ h;`^ 2hx ,$)|ca)PZvAzHKz={dʰSPSpEq~vzyʫO2wۨ:kKd }w = JAz'C'hH*ZUXf1Gݮ{Do(P^2ķjM1up|A;=ٶo? /p>r,Em"}rkN ^}kLa%bYq[b#c1U+WCM(& 09IJt3?j{3_F Bm<aN3`Zl;q޻uؘV"W 1ڗa%@9@9hrO6nm0>E6[1.S(IA 1v Pj??!席oBބ@|L[>NCǸ^d n[gRr)>m"CD3SM_f#W-}rng @ .(ݎl,b gkaALJ}GeE&&NW9$gmZzi&{9_soiX!_"c<.vq 0PntM$e[w8kA2^om貽c+Hl+C+/K ~1b |kBv1\sIzNo+tZ ONL|Wj2ܯ"(8갋EYD"uݘ0{ `(W%=FjmlR@yXEC9?ķ;zS=*Ā!._%}J׷Hv?-tkϛd}mm1n,Dq ZplcB^cW$`d~3J':Yl ܚ;#5f?LHFq8c?7)xw " ed{"G[`_X@(wș;Mxh7&s=!ŗ RI8 P'=G_onp=|E0c>\OGù)sB}9?C[~fZu$B;׿5*<2[~:)m&Wq;]\aTI}#ie^bҭ鍟{,`: >¾@C #n,ۗ}IC}d]O.4nʗVS```I/{e O?#'D>qT^D^`OxN eV~_vC'Wh[SXu}WKCb~@XTS;L4b/U"9/~7f%|v]C=h;횟u]8pfQpþ݃Uq cι-y?5|*55!zQ; #[ Fq40a_ x<+}9uYOKZuV?( AOM*Q+CrvLFJ}h ȼuFE=qlByJVS```I; {Lx|.9T=߰xzLX[Rd+WϪ5"2?%$3z_6ʩgCkRŃ ;^uφf! ]bh(“2٘H7`υjW^dͯCyw*?C^OrF_F=UtKrxH~@W@uRr8NK])o(Wѫ/i,X΋gc'n1 6a78 {Y V-bC9y F4br:WK,O_BzՊʼF73O{͘$U\e"FLxB޾:,)Dio>Sƹ طEٕW _ߓ1.yBfʯ:9vWXpL|"L1wKwNo'ud:MocƱ  ']Ct{_75P>@(z#m"|" dNn淶K~^s77-j?:Yh 忛ێ~ڗ:$agDr`1D2Ɩڎ7WA h5(((NpY/wǫ]lc?S_Yst S=ka///VB1 d EvH"> PO.6k~_"_47&xY>M9_~Te͕g-@9@9Z*y((*%S+vEMo@̶wCn? `?t)5ʃ[xCO+le"EV@P $U1$(*ZM@ @ hA}J @)r000 ?S42b,e[/T[L/,nQukU7ӿ%_9}l C>xYjGRe:(D/^ bDz(r000rtom~۟[⹷K>(=Cy c|oCɵ`\6ˎ薓L&1/{k+&6p/O|1 ? `bgEW Kϧ٨vzQ^Pn/Gŗ;hQ {l|uMړ4%aP;BK|4HmT-_2\yŽSɭtn@ O8܇+DmΚKS9j +Wg6_zZl-r000r%kAx0:Yl_1f4%QI0?&Ԣ|&qENU٨>/g2aJ6&xeToj:#H|7_Rb~ߪ5"YD_ #lvqg>JEI]7o+~ Sz-@M39\gRrB/1 +-/֗Rյi5Hn1~K2Nq\/YN t 4Xc*Y.#fu}W޹7[zGٞ/V```嬕f >/~hoJn1 @d4/ǫ{G.&zpfkFɯ㉺ ܁IjH>Fv X75'D{Gki(udvlbEQN0w*1-naJeg <Yuɓ_^vwFՉ^!xl9Bfa|1BS;M"'ޥ@LWi_ן>6{9jkLj〔n񇨍(O2pR"s-v[Nz1Z, s4 Q}~-.Sw%wZ*ԗ4g5m-OV—zi-JM51}UC"w Թ>Rn-GgϊS+v2}lEeVlgʎKb_dX_b[+3-p+dGcT|\vM'6?&|e V`]]0`YG?grs xߑ->ٷ9FWU؉7+_1ذTNK6'^nrFd)&ft8Dt>ߑ4/yͧ ߞxk]:q? kF ջ(% ӎ[j;+UqYA} S:w7YD71熨egr厽WI```xRCO0TIqL5blyZ-5xM1A@#~[[{:ZomMS烄!I(Pݩ)Es@3+w|J+}L |^9@ݬ8%>'\]9U+4-]6) ;MxeVV& iϮu. Rfw4~!'7o̒[ĔxgèIcVdQ5{F@4y Rb\{MTp^1.?_M_->h>=E ~J#˺[{,*D@A1஁bOȶ|mnkQG^ }FB:^N{kZK%¶^jlEۙ>Ɗq-ˇr}J]8cP. 8k3qg"s+j-{tXkh)vP뭑zd~y&W;L]hTۦcܲC`r\2OHHuuj K_ =ع2gY>}D #R,<* \dfnSNV )uCp d^S2Ư?~h\j$.f֛Rsd\AyPJ'wgUɔ1zS~Ru:8|AlW騲w KoQi^WI2v;>ђ'ߓsq ԣ13NY- .{*svi g5'[]FןFPݡ!ǹ1 4zHs>س㌟6g\-ù$/{DOxagKzf:9333mg쌭Μimgj[b- T,UEQ @B;! AnkE~@}_{1ܜ }^<nLv^PfrÎZzc#U~Á]OS45{~U0 PeG7ms>8y]3?yABؔz:gE߷޻M_>}nS˻tcP*c *nd ;J&}%1X͇]h0=^ś@~F5a՗ՆyUUliS0aSy0A߿nزhb&SP~%_+޻2& ǘJNg 7)?@N:"U-]ês$riPWdnI:5Zjb i[V}}wK'6dIܦ]qc։}$E(wSc[{v_eW];m y |cJ.J `0a5֪$ZZQjf *l-騘B/?}K {ĩڅ 4vWǏ.Zi6YNu+&ZMEeʣ޼`?i>6Oga+To¿\eȻ$z.w(+Y.2Bo_@\blkbbrp,Aٗ_ W$"S|╣f#K۸3m- miY הkǔ Q>gʥK4юAoK4:N֥FJjy%Tu; Jڢ{vU0/U/HW 쬶s3;[,l.Vƴ%[:BeK).3L),_L8]| @]X]2P)<CҒ?hn[|4[lR\|ڮ]$ Kr)ԝ愯gٽv>[cT#\ve\Y~,t[N)),"Ӳ"龥*b>c#g }o2n<%)?GcɴI-$C Tȃ\hk/ur͔en\oE*nWpqGʈWEryԺ ʣ6M^]!6MҲ6u/kV姲.)%ZE!˜R7ϛ2)jW"# #ha7Dݗt?D•>'}h`VsH.tA@||12|z3Z=^ŨE֡)uhZ$lէ+9N^*T-o}Eun]]tu%W?ˣcvS!\ 7\nɹ@@#xyT\SLy)goQp[cZY=r ꖽeZ=7|5%n=^SΛmfE|`6)&[= dv9>Yѩ Κpɛ tM||.hZz,}0s3%]!<I7p%~e& E{M|k+^W2U_6׷:􋓗z!uӔs3;L0c Q~zZ?/ϕ n4WnjuK{[KW_kum{tVj;I-!J솫@kzՁ|Q\#,H1wRsS1IsL#*k_WCuunb8\&#eCl|%m Q( j";begS?n:*|yJ\eWމIRޮf.Vɥcx=rj57njّr@xXon*GҖ%z{1rٔ;?Y2Rg (7#\V]߰^q#`eM^{둯sB$rLypT5ihϜٸ2Vnur,hH>(FwwW;d7%;l"IlO=\![\G-}_.YN~qw'>1Ly)?Y[Vntp*݈\K#LLWIބ2yleqmպMڑ9ůґm\q3_%'7&:Ynŷ\>}L9\ Y>!sHHZJ:y}j#7%nd靵od_{KۿPrYy*W]%#PrCL9\$I]Ha_Dddzz\LCKL:,=KoY#|?VӠ'cgO+P!UbYZXB':ͥ冞 ;SA"` ) +xL'eA4Ż63kK# e =9y"to1D7g>)PnS߅ε[jKj;֬~HbM"9L9y z7,ZLŸ ]^i<L^ƿYoJ,ڲ:g3pI2 dCʽ'u!O\wsOw?دKU@׵?CӔ_bio32}hF&oD1)QC>{w?/V|hN6 K>g)˽qД'>e?y}uM8w;eJ|a% VՕ)ɻHK 1y{؃w>x=m_{^hX{_ RW[sLހEnp~ -ѲsehkL==Wy--CWny^n}8_)(χv2C|s}~jtBҧ t7\&﬿qK=*>F/;ou+<;#F?=ӅZ͓ ۏ䋨[E^?*̇@EnMjr\/>i7͗\ӝ +xLMO^^ߔ8Θzr\$#^oXQtϛnٖeOZWꣁ:v=&QFۮG9oeiwfWƈ#ٿ~8a#[-w~?1鰅r`<Ҧ෥m_o~ᅫݯᴷ i^Q[&S qMh?f?ɘey}ucJe?5f1[o]s3Q6LZc3ۯ}$-9e3R9>[HslS+ֿ{/[a(#ٖ}90$ L\L9E+cKUp[1Ӵ2zoߍuo.ڱ1_$7QMyr.<۹ܾpp7ȈJ\yzeFsϽ7Mg "z^P\RGHL]SիI^,p9@n/-Q{%~+CI{-d: o*l\y:Z1:k[ew6rMMV=/)d3 J܊`~7^u)E:_y K ⎄(ju\(%wvܓ(7XfF3o===YYߙv;dd$5{([ȴZ:cl ]ǚ&+vo7B7ğg^">lKv8YPؔ6-9.30LGW\VVv zN{DvL%[ e%jߟH_!}h=Cc\Q~˔~**1䆚t̙O?MY*gWr:#$>Ḵr@vlWnf·q6c}}&B?n~eFZZ5M?x]ЮLo ZUxӱ)Д'dnŬ%XJ~jVlg/(a.r>Hkn',#uգi_ϿANZ$ӝ+௮+U'r#N&H%^`Ig7FHzf}<)73L~7csݴIGP~.,#ZHi>GbS7%HG?+а##.}|.}ў N'H1_Sk>t*iD(tl\gɈq2EMqs":0_%8` @62 av?MVGX[DwG^Ǎ|gZ$ q:V0̰VM$*ȅRÆ 8<_[/5yd0mlPa{rޔsM},8 &9 Đ/SCmLZjFxR?Sw*#G7H o6Bf`GceJxfr9ԻJ}؋S>[[l:~IhScȔH&c^S6I]PW"iɅiKlSLFUq}1b a^Wn'ŽX}5MP&A598O`kDqS~7}gƒ7c;ta),Ӳ"龥+WU ]la6* ~o/kGdZ"S.9LWѿ:~G75{)2"=Q(p4䟉'Z؊>sOMAI0byiSNG})̔p.A=f姲.\|OE33%WgtjFR|$# tRR7 %2*-ίp*ޗh",gYAn)tS\OJ}"r#4*VjMNvD>7v_KBVY">jqhL׌ ;wU<ҭ U"NğY!uD+[f3eR{¨$Nsw/roڈn1q:V0rȋT&rc6; Nr+ O|/l,z\*n[fճw^3]FeZ.t zÞC&:k%oZ7)7Ly}$-Q(:Bhdj\("G^WYz%̰Y 'p0Bz-#$0ƮMO,*WVX 1mv%\=;4^J> _x)e% [}L%?8KGT헋e]]qR{Ym`jC :M';Me*v= EwuT3MyQ<)̧Eٛ#2w,)=@fD#CEyf9hs7tgԛ˼ܼi~%8О@fpr{-~rxL9?J6Uu+_Djw"Fv>(OArn;YsZbL#jmu~ -VE‘h}3`yn-Ǔ_FzF7-&tO{O}uWΉƾ'b}%] M3L\T|!iP_&>X78Gr^DOKCv?Wܙr2xsyBL_1^Kv\m\A=̳Gğ%kY="77rCz½nCFx.(^`0Q%kQMvY2_9h$ZΚiN_G_uNKOxP 9i6XO3:$9S Z2ܠg^qbVmp1;LMS)mw;b~-:.k??V6UZ^;YPtE-9ƙf7M4ݓLꦉϩN Ԛ_L|z҉_ 7}*rr4Pz״p;aw^_@h^jwEeٍq$oL2"~k&}OhayH>MsL| |A)wڬm-9Sڧ:@ 7 t[sƅ@gX#=]7&N'u(r8_>:rzt=5`_Llj6_?FBU0c!hk5ޙʩ{W&E<@5q.5[JLu8pۖϨIN *S6S3PIDuv;-%'z}Io23knFO1_HOL}*rr1%)?bLxIfp~]C)xMsqAQ>w`FFńqD#o29~вL9"r{AU0`ʇ + ``! rr ٔ  h)) `)w1VA4W,)CA\SSA,_SAAsUft z{ S9   )X֦AAsL9L9ASSdq0}gy0]1)e$ Ӎ {GS)lG5wrslq҈4y׸xٶMڸ}oQ2~=a)\T7Oqvi0\SdL>F9#jwBg^޽kb'ܽ5JkhwN?nǛAi#”Sc+d ;{zMμyGD9l]Ԙq{{ {ZZc`pǛΟn<=u&t|>lA}蛴%0 I 2# VsktcL3nqc$=F)7H9mIޤpyFbm/j[Dn4ܔԦ<Ǖ)OcK \l``);d\RStxRsmk4= w!ҾQ~EA&cqMzqstE ٹ5^cfzI8MRI z>sm˖P~ܡLnPX~ӇX虱|/&ҋG Be#eMҼmթMymu D5g0#gH#BƸƑ٨6{"S&I<>s<#5 óg7sgrᰟZbaV4[& FG ^Gi&m&}^~wո6<"-Ag|U kXGGw;m3)5A)xJ()p#E^Dsd t!)9S&nw%8h∙bfIk\Kȟ`MgԽhFM\>֔ Zo>-)>-cʼGY33FƵ݇Ce~2/e污bo/Ԑƕ˸T6npAL91FOLj101ߛ:B{~4tC4fo+Gڋh#&1[QF|ݒb@ov?ً!ZHҶw{2xԦZ AL9r߽T[_!Sڟa>]n2zDbzS.싓{83߻DASL]=Lrov/ Šmʙz ˮ6/,ϫ2m,>艣l[=]SΦy۽=!7az y7V5>#D}phjw<ᓕ=fƜjnjdMo۲TDbMcwǺp>ӷ~Gpw3vWԒO2M&qfut+2؈bo:q$@IǕΕL=<0ESu`4ᝣzYe+[OšծW)Ƃ\<6m3:o dՏDa0Wj폒&m_R)7:<⋕`;(Wmx'AF0Oɔ7-!,T9nWluZ 5艼b/qThJ ܹN/)rSsx3[)ŹgS pqc~{GI;f4NWcrui1b /=Z;Ȕ_d< w%#+z8\>ku]|17[kݤ~4GI7ʼpxڡ_:/|{&Sn_Ѩ[͕&F9SՊ~mamۏ; wr/Fo3&?qyʕppnԥ A0/)4K!ӶIw-#1NxtpԤ`W͚@97b\C~pkj5΍GBSo̙,ܽ&K6s(ÂL/i!2Q\ᦼH6L70yS6?#Str귉GCɥئ0Lg3dU w3ZsnrOcʿJ_ )mQvwTJJ(xNaŕ(+~k v8w_3|>N"+3Ճ>; 8<>G1KչRORɿ))S9Uydlso(O)C7.iJ#kW<¼OXn϶L(d'`)g1 MF1h\'&|r^5:=γӬSh 򶒳# /4aq>h2jP 2;x"4-򻢛cb@¹fp#aeՙWI3>&g} Y>8IPOLng;ӫHL9{#1£F}Dg/V~dL@SSÔ_ύϾA"}xkeC 1FԵQu&SnpWaiSrǬT9)/#kdIbv $#݃.nēS}h`[];zNW- 'OY^42lyHu9vSq̙?W+Lv`?o&ɟ癚rtOȬqAg?Wʮi\ MAq\~ǞvlW?'qFKsG)D/v~P:_\z hSLyt8gz8(䭧oxۇ5]xаO^bKke k5l\d2@L9mʇ + `~;AU00AL9L9ASj=O293L2l1_0bGmAw]zi:lNzׯ:1->A~wR>l_*uUyxrriEs=.{Y{++ *$Ⅰ 2&xil'+4pw!?X}.9JXhZ:uUۻr|7m eڸciܐ0(U뵽N]Bn"}Uh1ǚ0L9f?{}wԖ8_~ZeTy;9r]o_O|aɄֱ)jbWo#KP &ܷO^ $_ӺI\MUW>:WΚdGurN3ntܑu7Qչyn׼\wj$6B|YθATjؑ#Ly>9y[2dGbm2b\woO}a)%^v"Gb_;d;9*S?rcm QkU\|+?̙:d߾.ku[&FM^O}Ylo-;?K篇|7Ib|™t-/~iۓMV빼l_:Z9^k'i1Υm*syؗ+sfQ4CzlљGPpS%7\~RϷ]9MTxAg;4\DC`^$S>d[g1<,ص{\P7:Cv3%c=zϔ `-`s0 ۆj+kWzΝ Ƙ;5=w|1gJ&ݲ;+SǾ(<6M]5T:'s?uʌ2-R'o{9gݿ^7ˮh%b6dR[9)۬#\{>d.>+>ytMy4/ɅJTl룄ׯ<2uUŰNjjoWTQXķi/=nc+Lc/=^!9d:]Rv@)W e"'kg3j'˚aϾ{ҡGmJ~3쉳Uq?qUj0olQέl6k뉏מӺg+Lj)NR;Odr["iCsng+:rFڿkCu/< -'<%SN/c`v2N)Ȑbz+$}c ۪h]~k Lmc ɋhtShns0.73CݰFxQj˩:0ھn&f4)O.Ml4{CVbfflr|Wt6cbZc|-v"m>KyM&$2&cokټ_n J趚P>)Nd? }(k;7AԷ[lT밉AmFvF`^0Snf.f8(jj|uF9`2abz0w8oSupp6tưg2ΆZn'v5^sLj2cs#S0gg[3硋31K$+SwVz0J7Ȍ@KĨiZ$R d==/,Slw0qJ|"/vT;I'޲s7) a[4l:N\fz]) Nql33DZwc4d-N^hu#"O9 r=&7Aڲ]c;(?}fw%oV(U/6_*D!_{uW;{̋q2S^Y- a#rE0vev YȈo&>3ޭXy3לa!bd>O-:52 jk-66a!2lX`O C-0.A!﬽NM]cH_IڭVgpxd7SLr'}O܃v&f5kr9t1 tTüqmi>N~cK |rkYΥY)jdҷQ=>F:oMd9u&͟"sq0G1& 0s?l9A>X3kn;jV%#>ʺ H,İS/5Ylz7R+j3ԍ}F]8-WґVBF^?Vﶨ+^bH}L%7 4M6mp7S:'q Y 73<(rCWe^_nW^zւ^li^6%isvY MyvRa̝^G/c}(-Po +vibǴJRÖ'ְ}IOy95-'g'`^8Snc.?2}F>%#mdr>梞|2Yv}ubӰLp ϹOg\ZE_D\egOx#Ο3ܓ L9'%9moR rL%~nt7_cz.976xN:z8i9oy1͞n; qu8ַ-6Q4[8v¼۾ pنRlkY1.jgԘs'Ei~O CsGc-2qN21wZV١=#u :  5t|`Ôϗ{NZenf7/*s~b5{(1_(S͚ Ԙl^n?x%_%g3xW_i|(lh|f4۔2o{sQSvwԲX7t+l|~ᰑg1ɅnLq%p:{dzҳtIΪM/ݞzË|}8Z%ﻓ4^sGu&_N..g_9\mOޯ.ʯ⪕Nmߧ[Nu?zw]E>gKlyȻۊFtv7oroX>˟kTw<p& c+Ig >`,ۈ_wiLa4_0洂1aoRm0Ϥ]Ŵ}=.kM-qM)ϧce֡mΟdOF ?TNi?xyۭF|ҥ)X SnMcs,Ps 3jm`Go(|WlaK}yy_dj jOe&̘!bnr3q$+08M "ݜH[\5 !5[n[4~A5\\q 8%7RKU望6R^@Sb;U.R}۸-wha$w,_~:*wZ 1>\W9[6/y%MFP>=)1҇Zې6"+>0;4Ф 76~Wɍ(.>o彡t ڍԹN\Wf͛-6)ida;g^<<5S~d8%&dB~bM!1Mf6=HZpDY۔ߚ!BnK ?OuF5mLM^7lSih!If::|{Q_\|~{j#V:۔ w_1@aBoxӿ=G)'<Ei2tO7n`!`rb\ng7#gu)~eM f~#bÛL̦<~ 1pӔ'a3 d4eܠ̹ZoϹ^o \ LIϘκb[<@G%n{t2ϣٴ.K:l6L^MfPs[b-Z37Ԩd&߀V3w:n+5 fn6y<<T\" mq%IwtthIGMigɣ>8}=,/d2䱷C=.v,hyՆ6l6 ܾYdeɖ匷r%6Q8tfN@p.;>E$E8to֣e]R=P ߼u4a@Gي<҉1&qy; o\TC`o@Ћ.rd^ӍOB|v쵒D\^^fŇYp5(PSÔKGCf+>(ڔjf5Af:y(gMLyd @yx^:;OxHEʹyħs7opϱOKmU54wVzڣOM훖M_oƻpMu'# 9o~U``Jy,'?4{ϻk\0[SL9~]2沍yn.4{z]&mw1iI^ L;4knٛ $>,7n:IshcԉԿ7v[{a ٘> ISCoC]@E0a-~^cjuAPCA00AL9){uuh Zl,)72VU{AzqX?N w #>W+>`zUm|e z)xƦ\ߥ+4̶ד2 G'$f_?C޻}o I `Ir2?~ZK|m{mI~_e SQp}fg`WAq'q~{^fd0Υ_|TW_oMF㶟㶿KNs>j׸۫#jwߜd ;y#|ʼ< ?}tGQ+oy8\j^u&> L|tTZ@8h)xJ!︅L_UTd&&@U0rң.>25zG[nKX}>m3Mt`*<}Fkq i685;u< ӭf￤vų32&܄2~'$3sG̐83Ww hD Q}AiYdnzwFLT7+ .y:"s/w=^j,]T|/gX?T+G]q_mO\^?;5[=ϱR݀Tӻw[ٍ.Kլ3ct &:bYp>~sX )x1')RW7483[9~9HUHE/3|#7;;8%S&3zèSAIE cljqqbЧgkac#f{pq={N#zGUmNr<mP 9an׎:2^;?=(-rt'͏]F> `%Ms{Xڿz[$+eI^bD51IL8sΘe>tm^bfu;1G2o5EdΩ95"[A6he69%Ϝܶ9l/aGֺ*kߘhW&e{Ɉz5zNbR 3eXE=]~; #8 !)WtG1V>'+Kd<”|2)Ow~hIZPG %]O3Xnr2(s)pv(zЦ*㾧\ztԃoʭ'^ Um=SУ3r}[5=er:`? %{vMc8I6q5m#7)'|{:eo,q#{nݱb= QY|P~N-msvɌμt'&z19Fȿ/ j] SX;qO]=,J2>oȾR?-{W ۯdN8 r5pU)}zGF]\}tefmY(ŞzsIV 6ilL!}1$ڊ]M=XJV(Sc#f˧4+}Lk𴪪#x ϘEYs[U1ݞ菵:.|mON9\K $o1cV?ϒ{N;qAASJ6n٦bcM4mX636qnM$SqeRgYQb$zXs圵iHZqFH )XSnnVM$ }Uvj+E]{= bL9f6qm6ߌʻԎʮ!n!)1r L9L9ASSd9ǭKoMcUc1=:ތSrUB|!JY|,6-~*M#xUW[;Xc#|=mܸxzK>QMGۦFi|Ҳw[NA+h%:rj˭kWHr+JnP _5r {]SrdUi5)Od ˧ŝ6[]N㜗Kc!rYXCI}itR@pDr6q ]cΛ=LZÛr mFf)JL-6;O~@5vQ1%ξsLFYMqX?i5"{<ʭS^B'9FZ@0j5u|?&Too<cG)//Ռӣv { O7]F;]p'n̞29Փ-[6fͧ46}~}?m;llVS鴷ޞmb˶M9{`=uzVGm@څMOVQo\M#{X^mv$oA8<~PZƋĥF?jȟG MJM_ez*~Ӧs$>ĠpgMJg;mSL~S0Ɖlߠ ?Ͼ+B=prlEe8^r2 [sf+gǚFT}o<ذSs7TD`s2}|kbC)Tp?WskS Ӧd̾Sqn٢ﲒ߮k欱/{zmIbF뉝Uљוk rΟ;uq+7;Rx̻=$} Hp ̺)xMss8)dվ1] /zeLר5or3_5dgC$Sdžq; ͍O $ƼNu޽Ϙ&WMw_>|$7gVLFt~=CO%z)7{oWLoX~]ދi+ɋͤ<5ՎӼ%^+֋ΌqhqOzc౲&^ e=[._m'?lk '}J>5lWp۞>g,qMyt;-ܾq򐠖*݌QI OuV|qf̡_NGzDߵdƙQH\Oqv9g}%^Tne_h%q( ,ڴ6ǼE]}ڒRz*wwSE ž.?޳$5INO|; )/~2;响 5rs;[Kf]jkċާ1vW$E.rU5,8e6=73GCSǃ!+1OJؐc™3f63S;yv)mŌQbc{+KRl7L}r5g=S/yr5@oId#c8_S ӈe5fi'aW[-RUǚm%^x[ËYf̡a oK?Ng7Y\zZm=KpS_N=+-=lьYB};µ)pj7H,:xƜ}Q ^MR6/}JҴOQktA i\00)0ox[\vkҘ}M`k(雚ꗔaINri[+ldijѢ1Owq1_N5IaoU~y.!la2OF0#RQ!l;Sb }AG@} cz{n!AKSp3Bwr:.W:w7>'4qTE۶Js}m!%x~%TK1}wEa~y A_ɱ}0CXΘK"J3TZ>]Bk޿ WKnթ̡e/C!^ӭ((;]-77Wy-;P3w=7 &r8rsS8)Jl /}h;ݣ1LkdZ;+dT˔)ar\uh_f- ʮ57M6fߔ)㓝ߑ|1K\fGȘ ̍=-՘)l_w>Ճ˗Mab0t[>xj!0eW}#&8t?5f[}W68͌yԋ S"&u3ՋJc3_c!ﯖF{wQrWx+ (a/ſ,NS>dwܔdSk2ڞZFdY=U9l Om7U49lF*VCG!/-ʹ/T֭tZvⱓ}1٭3zGPt_ l˥4zi}H㖢Ob5-VPn&3V7DorZˌ `5M9f[Д?R!O5@~o(uң tyv 1([ZL̕(~,'liL;4jcjhSN>f315Ό~#oBfhSWWjm5_Cn) h7eRFRɝTq Ǥ{U&?W7&qM o+q3;7r--X6~g_ØyWx박>:EP7ԫ<S-|/O~\\KMZ>ҼIC}mc:e*W4 }5t=$ܢ|/yMې6]+\ٷ{=UFʹ6"IyƁX8/{}|i?*=, OMKdA@Ō5r3yx?˖ \æs&4rrؔFjL>z|^7ѱ_l˘OIZVcnoY)o(}'3s&.,5dg=B y%)'Q2@g4gLEg/x[@~W,e?ϋgO񏦼?֭~oQx[,0{cҴ'cKM9miu1.l2ltqɱ(MӻEmM-zy eL}y}r<(8čǐسGr5vSMiA[ĭy3$v9qǫܜ);@untirWϔS7Wq6fLƀhOʇ3&ijq!?@W\-Ce),7fٛM1޻{Bj]euie22WcyNLj} Gm! rĔ?7@AP))%1M܎Y)Ҷz0 Ǒ2͆^c6c<80cPHX 4&e`hhi,>Bk6,*OD>TnZ6س/*=Lly~UcS[];S' *Dۿzm%Ȩ~mݡռdÔ_$ݦ¦s4h[Mc׮ѿGݔݖîJ/Ip;2eN SMh{dtzԩW',ħ](1d{m:Tj ݢ ĦYq}R(ⲅiWci(/8J̢GI7 )rU4u%e,7]u7r7և5s6n_s vm6m.߲5tM_ϊ [bf`y5&*l[aLy|tyL?CW( H^ M(&Ns}-im6O7Jd[L Tlzwp.9z1&ŬF7|S1\ q7gEN6>yWx۹~;u:UHݮNqgO pL^537ְ>:pJAe N[G޶1Łz5wa5^q Xl3 (+`MyusFzr_oWvݷ#fq26mP 8R2x08`Αo#JL&ΘasѺ T]uon6r jopyv˨lW]ZѸzq)s[:ܨﻯwHF2jn# =/m|;H1u) iviΊ.:qS`~FhyV2md4OfMmfۛf}hWx$sS[2zj;vyPb?ǨLvmC/({dGu{mN#3ZuG eMߒ:-ZwsAoW#cC[T'\a\D|`3iި3Xh+(`a©SfDn+۟ޔ;% (~~p2(;5/pA0eޟZ^B];=cv_e)W7h6҆ {'1=SbTt{wtD5bݗm$)]KC==ZG,1,1:?cgukOM㬦t:ꊿgFy?`~+Y̫ge3ՃLM' nGV;T:b}mګ۾ű;xF^GIxFb6_Se F[GڶA\M?9FG;:KX@mRSJܔC< ')L)gZy%Ͱ2 r&<ӽ6+S:y Nˤ%MB皀zeє.gK4'3/+2ӽK ͭsoJFzF h1Q`[/H*T{L5t {OrS^x Әn/1|aM~є#~e%#\Uh684ħ'U+4HnIn؜`-޼37љr.mܬ;c팞K`N'Mi@W`7(#,7דd%,.f ͍M4q7󛥍ZyQi0jMfQΦCmSl8鳛'[{XF#iP*nkmX=l`LUuN.l##=#2ONN#1-lۿmi&M%3twX񉃐) rWҔw7d$Yg}CVN*)k<f^WHb>jC]>E}Gѷߢ=ZMfEӖT2#G 鞤GȞZ^Յ0 6 1˵i#d;жOJ^pra鷚~R5\y2}Md._>&n*Ym]wqNv_cE;c<qroyEp;D[J MB}!YcڃT]OLQQ!3O;iW#!IC}4>߄~)X5Sic@2ke&m>g\J&qNAD)OshivG;Ia(4qxɱ5sz0AKmLKFsY+t|ͅlYKd;h[Q*kLz4u$mħ-ɫ+}.^súj\W0 *SnnؕshgXmA9mCGnIˌjԥDFNCgW Rt<1,4ڗ˨uVzSS!Ssi,2Ε-UqYcTiS2%J2&վdCA0)wQ7WA`c,jMZfŁ2PՄ=~:v6v,qkQJ#)t\))S7V:khγ/1{~cGg ƭ.Fߩ2NkW:ft˭o[,āWwxV_3O37[wN+-=.qmIc/OW^nc0?2SҘ4WnM׵ό?zՔϪݲkeIC&F +EyȻ4ګVrL]ϓzQQC{q(;q?|#C</v͈RJ-jW ګD ۑ= նm&]C?8Yf5+6<rU19U8ɟތ̷з]q!߹+ڰsļ֔53ͺc '*F٬OFttj[^aұ?}q:'{#vi>˪qK'.3?)OsnkgR<W6֫Bs͖)[ǟ$x+Kԃ66M[.c0}ܰ3\y6&I6_{35p}kR.5_\Xk7(+y\BH:3[:2e]8lgP6~a .K+DM8\. ߧ()Gݍs62}T_Rmm oO.tMdm!ڶ m>5* w\}<<)X%S][b%^Od7.t8JkMcn6\+ijO$TQ;\%kS>+{]oD@脼dnBܙhiwQ fǺQ̶5h?L:7_c6=){OpW}zO0)174JL<; n,XEF E'78tj 4GTG|2)T_ZbܘR"pm,ֱ}k>tIU u)VXpy&Z4mޤKQ7Tw2HQ<{ԉ̚l{6u) ZeaUq\ul`yRsyRoJ=M97ያ3zѭj(6Ab2o(%~:܈hme^۠[F 2V ':nT(d8rҘӗgF /zW>3Fά첷+dU;}f'?xk4cj usZ8pe{b6>ްaúE3IbYCwXUt17m_n[y.`g vL9+`uԍU8u&[`6uC6ec1 =\~MKnCvI7`MkT>M\T†¹' ~}Jo7_zS hOݔ!m-}fyPG LQ@r81:Ӣ~bt6¾ܹJQ-)?cvipǍ1F׼,J{N 6_p#lg_q ~OlމCcqwTH@M1v}e:mmo:OI绣m[_r[/]ݡ_FaGK|u))w)él_"ER.<9;/ױ_l:n+Cן(#:wFIֺ]tu*L>Bt-d %D݌oU 1|#뒺!ոVo6*6եs7詶{zhZ|}[@ZETZ iC̶SIVt~˲:ZTp(;'d[FYwrxƁh]v/L4Ӫxā b痙L/@[DGv]m_n[y5{pom}qyL9*'Zڴ=&v+)ߒŢ u'ׯZI)H~ON)(;S/k7i;sv9fnlW|:8-|-쨭z&3jnOMm(̟tMY%;'bê1/MKF o<?;]|S3 kuqJ?T;F)%oTpm4Ѵߨzk>T1k)_00sH0)YE4zgR͐Rn>Ԍ)KKL]I}TcJ24m9X[O8wXApl~SI+SV~;TpSMNl{m϶$W+rr9AE+rr  )QrM\AE+r8r Vrr %s{r8rsNAA  )x}M hSSA֦\ >Bnq%^B)J[_<kUMRB QE(=Pqq{Brf 3֤w,51ŻOc)x)|^*驸2)_<)5*[ (/UH7P<2)܎ޅ͆JlysI7PHqZXdvI vkcoS)lsISBx[e]#f`V͔{soXߢnEDk.d &8;l;6p{o%x+`ϩ$7ۿ_R%1q[wK:=C2.$&Lscfw˂l\cz-feL\ֶݣL.N_,'v$Jmc}U*{3˝"-W <$ΓV^,t'{RK~-UGf)xLysy@awm=Ak#\kG }#~-MrhSn^jU2;//L}*Q&:E)/X]6|?#QބӁ#꽴̔\^_+{N<;96cBGvf$rf)q)[^Ӡ"y7\{*ֱP$,!G^^hScE 3m2V73PӀwsyӂy˙NfRΠ`~B2h]V&(ZSfDd4T=O̒;`(o~InvY=K^#J:)l38śY!iǖԨFo꣌;>0֗>=T3TȺVirif0~J*0緲Q 4r ڄeg?,=/2}1[Qj) 3`^sSHfsJ*2q4jKk .τےɞ%yu) x9dB↨&+?4!*F|*1gxSs;-*n˯ZNشiūc<ښf>9ϙrFm$חyNwT6IoK+q Mc/3EY->؏a!r7̔w45+M]9714l7mR@Ȕ3t`vDS3Z͠MJ}ήLΛgV^:OH+b EUo!Soq7W`(/m?;{Bz<)HV+P|/}ÊUܨ/jq'c' fPrЂ#.XǵQZM>cE 3QTdVaAYWO.;Y'|Bqwιhwͅ'ϓWK,B0o)^=~8P Z<ҜmGxS!))wvXmՔ4ioߜ8I[V7)) ``! u3 iZ-ZNQmfŖ,'_e7~L9xLyC]-p߰6F{{>wb[2]1͖xDTџ>u4ɹؽN⩸TIE.OS'zWr^)ru]A?723_MS.S'2h;f4@jhk6X|v/U5gWՏƷ}P) 9*[ mn1%U )#N~eR:}%V~1.`i}}}B0)HoްEzSZ{t!f@Ō/1v{{*Gny3’\O6WL˜kwLi|qj6^=eL~ތV&9WDŽ{ӁqmM͊$sYN2ӕ>ägޘXygzXIKAvIn-*֦,$$LU4\vw[BLCUw~o{GQO YyN%g8"0YvBLB'nqd# ɤ<ΙD-b1u)J;/[!olmBfSS E~~˭O S S1Er#C/ߵyNy&};ۖHd=;Z2n^jGK?Q3ʔT=2rCVd=P7i?P[_+{-vg]\ڋf!~FH/eEǽ}JA6Pkv?̿eq#ekHΊJ&oNnj<JOO,ioڵ6u2]_JaG8z߸vkx~pen_ƵQ=ZnT4H_X%wFgr,#gwvXۗJ%≊|T(񂷑3_$ i ,+ҝ!_V뮓NeI<+U!ȃ r-v8O}Obr)o yF͜ y2,2b.KoJE+޹N<r͆<YRg`XSNR7Yٛj)1"Φ\? -Sy7)sd.h'7Bd6WF]Zб'ʣS!6)˛L&=_ٍv4.GBZ;vpS>/mK<˛􊊎a9cr'赲1^_c-k IAiԏ}Yˠ`eXru~` !n5v$;p$9OFWLHjԪFG)wroGU?zGr5Vn_X>&W")H2n֕<~c0咦*3b^6c^Z:%**ב9u26oQ4Y#3|ʷxu2CUE%:Q$2׺M@ͼC~+P|B` ze WfuRzݱ{ōQTe%34~Tﳺ2}KMzw#! +.!n0L姧s-Ļ~f U-T}55IC>`hSԬx7wiĠKfzz$__tpX&L]msLdq8No,~veƚ:|jw Q"g:[{#9u;7_ e8[e*$+FXB _ 0+\1~+YsIVG/>gMd'<|Wyi{ܾB_+)׾7}q@k7*"Obr)F ;Uc2Uxd̺7d*\ ca|HeV)2ůhF'fS6 >XSwIx[jN:}e2|V>!O 6Ы$n/72ӖN~B/Ft́xLOQ?)0?yEĦwkWOMoMIF˨|E7s;]oj rSACA0OOHe9Y`OCL9xIӪ,)U*=YzWџ.˕,Q8)ױOASZrEje;i%{JQUle;f4@jhh#=y;Q9<%6}(uwhk*+3`^)4&ߛmKrnb^^hb׹< m^jGFK?Q3ʔT=2R"IBΔф˗^]mYɗKSfH/ew/rkv?̿e&oW=+*R93HFە$>YnGvpe9 NʐIu{e'2(Z%i=?bDz=;W< Y13 59U5*R, `V͔?*]y%V7{=}J%1dF19J՘RNəY8M_g`79뱳B2F: NIS֦,pS}A0ख़7~)X4VoY9Nn:0_d_`z#{պO7Ħep[ś}~bWѵ;_gXYg-$CқfnJBSsɣUܢ_? ?cJCOzI77=5b +t|V) r4tQD>S^?Rn5z#LjZ ɉѲѣUrHP)VߤPޖ>JFK:GC^Fʅ rnj5ۮM-zOEPQRM&EIUŞGFX $!̱1!QdT!˽aM3;8RaPy7rwO,+keayb&W> %N) r4圱]bv 2bTDIL9YLx:!uɍ7אEdԾY7UsMu@yuc~g<)4UeO/Wi%5%ZCL9rb&Gt^֔NRSMN::0yEӊl:@zBf.No4~vEF|%>) v>_9f܃n;fu lgBe䃾cse~y+_2/Cuq}oz7ࢁ2קV!fs_]X{t30a `M9k腲6@ XeCcCcDCcDCcđ&gbI6qD3F$r0L9`4| oq}f @XiBG h%D`ʧ^@APS)_ x  S>EDAAPS) %rr 7SsAAPS) x  S>IDAK[Z(1+m߭LS~%Gmw\8=L(_+Ue?+[~#UL9@||b9 :3&|/|B QT+sĔ2Զ軿n'M<=Oi+w<Tix>)ʔ{ eY\`*'2щ__~w(s=w#‡u }֚nt:O7h=s=%瓒OpG9燤} [yJڷaޯ#|o(ϓPy_|s^T24⇽NUZzL9-'^|*i˵bMsM~ӊcmhc6)㭃My1/m_Ww ==7=w}{ rp=CZp4.z <0}?5rS ^z; S~ir6W|Gto5'7y b]tz R*+o{s嬶ZϟηoP^M7 & l,P4u˵۟߸1XZ4L9C>*)ƔS7Q5-A7 'OŘZbY3[\=m5gR7<)'J:4]=$#Q.kL5ʋ{`W2yyx>*)”{f!eüS~ŀsvlLٳ\+9ޭMKo(_PgNጷwoAc2p 7X2WV5wcx}uH?0eOypD?=[: :S>A/CY~|ɇi~07(x^*z{rbaє{fՅ95ޙ[c# |3OrES12;Jw}?[˻?0y<'Xv/?2P#pPoʵ3f5[.y>~|d3 A=vi9y!oB>tHfM&V;ŸgqF~pV[0ј1& ^LzL:=>};E&r(Lg ^ Lu4+g:T#ӫG6}v0ӇCPĂ)ΔOBAPSSA|3AAL9L9ASZq `0C AK0Q1AK03k׸mo;i3mC;tu2]RgtmmKTZ Z+@DD} KHB$$D< $V[t>Ǖ{2Ou×e2m̉SGwߡSUk~ڱzν>SǛ_{[Oyv;6׹it;tUh#]AL9]`k"\=O>߶gUw:‰-~'8:7}qeio^;|8]m {$77\^O\o&ԧ֒[ktcYIz^ܔ+.n_tb*eId>/>U۵]aB=.Вr%ѧH2kn=EʤQLN@A/kNMNЧ0^#]A'r+Lyj(d#v%1ak-;FBK18dkځ5]_em7S9˩h_fbK8 M1ٍl_ꨯuߘ>kiڌ̆\m+!fq8ď-d,F?AH *SU3AzSLs41k[ZikA9D>z  ')”_^) L9\C} L9L{E AA#%rr 7ꚞR,TKK+;1tS`)yբ2۹g3֤¦>\eG5Q#I8{g{R'"KU;S G-[5rq f?εv|L9U- ;]-oQ3eDq)EIs]_FH@ryIEy u^rVCaw2ݚZf] JQ%mB+eC]ok"4EvϿ!)r+Lr(2S>(㸯] d9LuNni2F& S݉2kzϝy[s򛕮ԹI舩K[} Im.`+ #;6ǩQ/Fc\#e>-)R2\ST\8&ݛֻ?/!L33Wrs&jbǻ*vs˽NVj_<[ݜ}ꊍOWe֜-rhJ6戦IZ"Nqx~@+.__T eb3տ+EGTfxڅ :Xcʫ/QCHVFeQeZWpD5|RSN^F:)>UCݤ Ha?#VJҒSȵw7e7){+L&;&2d崙Y)Tns:q;cLuo->]J*2 >ITUY"*k읮L!ϳ -3*bP K6QL=%Qfڣ_WfIjR6weRq6y=*6Rn4X/nP 4iҸr 7;[In+kj!]հ~I?J k+)P63j+QYr}q=7Fjhie6 'e3Pi< jl9si`k S`)JR]ZWכĴ$ԩ UzMݑWZsha,LWdJ9 n`a$dϕ+Q,i@ >8Sپ)7oXMTX{)ʯg{H9m] * >Җ|ځbcuHLa\>77`k S`)WR_K@Ɣ7+)S&H=lY^֖(/QRfnw(cC]]jb LҽZuSF*9WPge&-i@ =2iicJP0w"ƌJL)=S^'Җ3)R4rbmFIsJ"F߾e.zXSR?׮p'71/5rɩĦ(JcӕtJ#u,IPJl=1`}NR/?S٨pg̸򀶠zٹgLyAoXk ~݂)ƔȇH"&JR7nSnzic긂үKHpsSwב {wjy#Ji6A2n)aݮW(שFWHO첸fUY\HI-v7b8k\Cm/벨}Fގ5K~i)ƔWu_S[xe) ȋDQ&v6ԗ1H[%r;Дf*B7_VsQLTuQy`Ş^qV9CS+2努A`1=A4R)”˩/PJRR(tZ u  S鮥Z/#X dOLDyylBqח,M9ݗO}Vg6ψMRl<]R6l*nZn߭45sF~|oJl*xkD%ݼ-6)sAw`Fڔkd q)SJTm[a'غD(JSK&3U=w}}y r3Ta_beڤo˭n\S$Vg|b5 |s/oihKEu;QExa7Uʔ>!r%i(1PNEbe9S[ rܔW o#.1w,r9PO}w<\LNvK:$(5};ncIT<{c9%>ԡLuՅ҆5c6MBڄT*Tqȡc ++tԢ/d};ԝt?? 366:l3bf1aGܮovzv[曱-x cowlܸn-ZNG͡pu"J/׽Yr,WsQe.mK 5NUfȖc*9vMm("u3\Ψ*M:fCŘvubrQF쳥-_vlftnpXfO [Vl|oEuCֹ y]uJMZ|kSS0¦W+J a aBl-֛T.HnNyɸeT"΅dư6)ZfٺM_\-/\밺7T_SAmQUN=^4 Ωٛ4:%0T6G{㿗pNFUPY2˙N#'6XΎ%=:E1c1v<]AҟL(UExy*xLcn:N*-wixb`\Y2S 0E=!KHd*ñ4VAmRó;ۛϦUHHqmlCqvRx&*Rim샻 Z1bLmsMq1\KnJ7Q6-G˖i(S1j$'%AKCp1$h~xeR}(_h@8U͒\q *+;XI_h=v8F7u,p%y F.1.,avD,Y޹3I E`b,me$ёg3 Ϲe*rj#y]tK 2SƩ?gz`\Y6tg :S.REA8[~&Qdž"r-6fr2Qޢ 2b.4ki[8Qϗߨ}>HS5n|Jq0"^M ּjW&ˑ{VۘY;m 3t3,0xFίxRf|i =zV0}%|`:vC1ַq6 z#Es=ο-˸^:׬a~òq;PXW̳=K5nn}T2skd!L9m1zALͬVrfȋG;o)7Wag8wS&L.$ibI؜hElYTYo&\lRNqAhNsAQiBHcEzy7.wo$[5<(gǞ+20FϕܞRh؞ԒȜ}>޾]!ry9зqnQiSN̏F~F=tZzl}ҐXa}; e99ZJ>F-'E? ,+`zS.+ )LDr9Q6VF _EJGuE*{D (srR˔uk8Z}͢SܑÔ5P8] yKzG!/-LS]%ڽ_{UBc Lgx>z^$N *Gcs It]wuG-Mh(Í1h9H IN])~ 01']\Hݡ6LY&"o'8O'{Db;:ҽ_6GGW.UD?@xb/I$'dCf1<~i!w%TT]b.E{_1k./%f\6ܨ<3}>2>UϸhaHHwg>cf8wOMܺqR@T5[c33z\j.`~aܗ-A!F:>kw9. ]#(%z%[aZnw}&Ux6Rq+P],$?F\S?~iq{%edRq̌ }p/J} ˒hY y|zd))QS^/WFڒVCOy#=Mvν$ϧ.Qt&]_9)ḳ(C/DsvV*^FC]#ܴb{@ۛfzhPbTqmIh,hʇYU\v $t:x?}-<uѷ+Fj`՗gO3;c[G9fG[O!͌1}[e]nAQ^e/8a*<|fv-^C=g/8~]V;6m,hM2 9ktnsHɳ=K`s WhX[Ê{׷kn͑r['YyHj/WLmj]ܴM^r*S(b@<γ7R7b3ta'o?_F79HnD%&El7 aQѶ.:@YŋbwV_D64PuƋ+ljdʸ )}ݺT"cy%.8>Ӓ#ova ,GĹ$ }R|%Ա58p{yK+%jn_"|xlkԘ|ﰯu빚 Ubq4wzДG!5<]&^1ùgտ@)"ˍqcPIgײQxr2s>Pkm2[λ%7B=-}LÒdsi]%&ܤ)VWf\[YbbJQ{LA&f-O]HG] xqs>ĭ &kXhv (gagZhMqL9"e*A˗7 Qrn~u ٕ(\ck|tqIPfɎ rZA42, AL>gSDSf||j}072)v׀ĶnFcskа@)){Œ݆x̨۲qlέwqi47 7H85gJ"jM2PM"6؈%G)/TW W;FfƑn6|c͊Ԇ#%kdKI s .+b)ZN5EY.,t7"ag”O7ٜ-z͚r 3y䐊Dӷۖ^O]k\,g;4pT?^ؘ4wtDCae2m75-CjH,>Z/Rs.I<~[6¨썒`A]=”}cWkx=GĦDݵ{fg:]m I}s_9)#b/fبAIEuͬG3o'}Ro|֭7'ua e`ĔIH$k6_My)7B$r\ۿxMEʇYc7ϩsL]v7b,RΘ>n\6[^t9GJST${9g*jTq.imsI"|x%y ʂyp-cYפLA"~[6>SNֻ*h1C4'My/Mew ,/ ?)O L9)?VKD=<=6D577;e39`vc~A}^|KVauԹ3i6 ɶ[(%Ȼu)y6@v&,_# 2){pŚfq{ !`HgnniKLeZ][Vf>eĨ&d;k&1o$b(Ϣ履 7iʙƔD-IOhgr賾3!퓬 37L58ย-evL GL>ծ|up MU[$ׇnڔ[Lsi)7iʥRY,V_;iO>yvf`M_ Y[8o&Fύyc]<$jwm1[DFyq&SnA}a>Dγi񜲾t9%=)oUD}]H{p1S}Ycjn)C9`zJHrY{(;Á|ύ㰄ݍ`tl~ M墉ZS>yl5D;`o܌YbF_`v {"L9-7/~j7sیhf#Ϸ η Vgo>u9T1:oW˳d'gݍQY^%sa|舭|3ǃ\1iGMϙq[H(zGEsSp;Y\jm1Rw]}z>*[%U|W_0q|v_洙 R;8[ow# 2t /S7 OD+zg r$?o7}KVLtzY/<虤[!rr  ``! rr )) ``!  ))  rr  )0AL9L9ASSSACAwK{-SAA#NO 0)#Att[O[cljF7Mʔ?6F4|HWݟ7'Z>3-z=&IQ} ?Jߦv}GȤ'*Wm!O8jƼn>^0\M4J'Q9WS'tMɫiy^ ~Sѷ"xZo_^hsO}_L#pеfw]w+;n~5wƿ7iʸG){]SFVO e̕k%[4sF=x5wƼj' h~QoԸ}WZ,=d_PF\ƿ~+j 7$dٿt5Mި^|0# XIP}]…OWG{iכ/\Brʜ__o$?NoڲH#DQ>}uʔPο:0ipkzu!y_o'ZAF&~Czɾa7A_(iS~ߗl6zt|Ѷ)|>Z~_`ZƗӸ1^/h9?Ĉ7G{ d__77sʸLD46O/ ̒܃"?;z C9/LcmB"^{aEB?. Xs+?87v!/?C_^ZcM7m{}G&^cSug{56I?1j=?xŷþ9s<`7_kq5Rqppxa8f#6Rc7:ɼZ&g|Ⱦ6~ Î>ü㦓4Sw|y"V}5GzO#YGUY\v߇mDzLqOz\?%)vCB|u tawW=fʔ;9{]^<AbȽ_ʮ,Cs=}6!0\S>=&Xbب,f#HtF9yiɍ m26m7M>}{;c¶s219a鸘#9n]>+S5)uqB +cf<^xॏvs}g k n)oOޚ6O? ߇b KNKH||ѮT&}x^CBOg?I /?#;q]ADIaȶ1 ¶v6v)g_d:z~c=A0#cNuL@שI_Mrb(DqYCK}zpqd2c\FyE1~sζ-i4&ʼ6i IPeLy$S֔2yl8}gs8e〶0Ә涥fNN0= A?+ʔYl!tQĶGFߖP1ڤi'DrwlMMg;3^x]`w`CG|W꣋"}r|gɹ )_J!gZ:'="Y)vw!=/lQ|g_46BWvhyww{}ԜM`7O熺 rbX̘m bwT&Wbʹ[TՌ)7΃֨~|f"˸Dlcr<87̷ς̪)3D}fo~0l-Danlr? b'c~c|2);g~}iw}EҎvx?FmグS/ [{Ezp^QcSN"okkI]olH^ U$|.wfL%u}(TY#c6x7>,{[BW-s2GܰM/Kn~%eyko֔3[??͜bo_7j =1X8ۻo)6cSΎ\qaA3Ql>c3nX etK7jv0EHz(SMSs޼%O^T\9~2{ɔ;1Pˣ)?rgYSnL+G-sg)g9{]9~_ߕgd~%͚r3 Sϔsy0޾n՛ryڃq1y|T۸弸̓ogMl0Ɯ#Efp  %o-{)>e{y=rڔ/ w3eH{KRwo  [п-פi ?~:` O-ݼУ1*yuc -]6-y-~;7,.]:yf]/g?v#RSNu:2XW?'Ygf)|Aw0v v'N",Y/XMTOږ2;2bK>3"w,G1%k5o؎LaGH}lG,'ew6&~FHyO-B!l1,\܊|D6ϯ} |hZ᳞^"6?27K)Eb=k˩ LJan3eL90KMf`#hȴ1Gsag1نN52\Jrϔ=ia~8E;][3EK7K_y^~aqKzo)^eO-:ev=6jt[&&͢pbIH9,<~X{_Pzx^(Qǻ&e{< #~8=Ou蹀/I;Ϗ_-YonHUqع x>ڙoߠn'ʚLޞoQƟ^'?6=q듾}jIĄ#~7-IoZޟoVIO[.5*qOb 5-_/9|[g b7HυN>DYyхw4?`DWWogͻ<6} t_#Nyг]^/tڽn9o:u|I z:2ƧΓbDjE?>5IENDB`lens-3.10/src/0000755000000000000000000000000012226700613011352 5ustar0000000000000000lens-3.10/src/Control/0000755000000000000000000000000012226700613012772 5ustar0000000000000000lens-3.10/src/Control/Lens.hs0000644000000000000000000000556412226700613014241 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- Usage: -- -- You can derive lenses automatically for many data types: -- -- @ -- import Control.Lens -- data Foo a = Foo { _fooArgs :: ['String'], _fooValue :: a } -- 'makeLenses' ''Foo -- @ -- -- This defines the following lenses: -- -- @ -- fooArgs :: 'Lens'' (Foo a) ['String'] -- fooValue :: 'Lens' (Foo a) (Foo b) a b -- @ -- -- You can then access the value with ('^.') and set the value of the field -- with ('.~') and can use almost any other combinator that is re-exported -- here on those fields. -- -- The combinators here have unusually specific type signatures, so for -- particularly tricky ones, the simpler type signatures you might want to -- pretend the combinators have are specified as well. -- -- More information on how to use lenses is available on the lens wiki: -- -- -- -- <> ---------------------------------------------------------------------------- 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.Equality , module Control.Lens.Fold , module Control.Lens.Getter , module Control.Lens.Indexed , module Control.Lens.Iso , module Control.Lens.Lens , module Control.Lens.Level , module Control.Lens.Loupe , module Control.Lens.Plated , module Control.Lens.Prism , 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 , module Control.Lens.Traversal , 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.Equality import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Indexed import Control.Lens.Iso import Control.Lens.Lens import Control.Lens.Level import Control.Lens.Loupe import Control.Lens.Plated import Control.Lens.Prism 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 import Control.Lens.Traversal import Control.Lens.Tuple import Control.Lens.Type import Control.Lens.Wrapped import Control.Lens.Zipper import Control.Lens.Zoom {-# ANN module "HLint: ignore Use import/export shortcut" #-} lens-3.10/src/Control/Exception/0000755000000000000000000000000012226700613014730 5ustar0000000000000000lens-3.10/src/Control/Exception/Lens.hs0000644000000000000000000010511212226700613016165 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE NoMonomorphismRestriction #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Control.Exception -- -- @Control.Exception@ provides an example of a large open hierarchy -- that we can model with prisms and isomorphisms. -- -- Additional combinators for working with 'IOException' results can -- 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 -- more easily in 'Monad' transformer stacks. ---------------------------------------------------------------------------- module Control.Exception.Lens ( -- * Handling catching, catching_ , handling, handling_ -- * Trying , trying -- * Throwing , throwing , throwingM , throwingTo -- * Exceptions , exception -- * Exception Handlers , Handleable(..) -- ** IOExceptions , AsIOException(..) -- ** Arithmetic Exceptions , AsArithException(..) , _Overflow , _Underflow , _LossOfPrecision , _DivideByZero , _Denormal #if MIN_VERSION_base(4,6,0) , _RatioZeroDenominator #endif -- ** Array Exceptions , AsArrayException(..) , _IndexOutOfBounds , _UndefinedElement -- ** Assertion Failed , AsAssertionFailed(..) -- ** Async Exceptions , AsAsyncException(..) , _StackOverflow , _HeapOverflow , _ThreadKilled , _UserInterrupt -- ** Non-Termination , AsNonTermination(..) -- ** Nested Atomically , AsNestedAtomically(..) -- ** Blocked Indefinitely -- *** on MVar , AsBlockedIndefinitelyOnMVar(..) -- *** on STM , AsBlockedIndefinitelyOnSTM(..) -- ** Deadlock , AsDeadlock(..) -- ** No Such Method , AsNoMethodError(..) -- ** Pattern Match Failure , AsPatternMatchFail(..) -- ** Record , AsRecConError(..) , AsRecSelError(..) , AsRecUpdError(..) -- ** Error Call , AsErrorCall(..) -- * Handling Exceptions , AsHandlingException(..) ) where import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.CatchIO as CatchIO hiding (try, tryJust) 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 ) {-# ANN module "HLint: ignore Use Control.Exception.catch" #-} -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :m + Control.Exception Control.Monad Data.List Prelude ------------------------------------------------------------------------------ -- Exceptions as Prisms ------------------------------------------------------------------------------ -- | Traverse the strongly typed 'Exception' contained in 'SomeException' where the type of your function matches -- the desired 'Exception'. -- -- @ -- 'exception' :: ('Applicative' f, 'Exception' a) -- => (a -> f a) -> 'SomeException' -> f 'SomeException' -- @ exception :: Exception a => Prism' SomeException a exception = prism' toException fromException {-# INLINE exception #-} ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ -- | Catch exceptions that match a given 'Prism' (or any 'Getter', really). -- -- >>> catching _AssertionFailed (assert False (return "uncaught")) $ \ _ -> return "caught" -- "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 :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} -- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding -- the information about the match. This is particuarly useful when you have -- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- >>> catching_ _AssertionFailed (assert False (return "uncaught")) $ return "caught" -- "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_ :: MonadCatchIO 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 ------------------------------------------------------------------------------ -- | A version of 'catching' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. -- -- >>> handling _NonTermination (\_ -> return "caught") $ throwIO NonTermination -- "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 :: MonadCatchIO m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} -- | A version of 'catching_' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. -- -- >>> handling_ _NonTermination (return "caught") $ throwIO NonTermination -- "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_ :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} ------------------------------------------------------------------------------ -- Trying ------------------------------------------------------------------------------ -- | A variant of 'Control.Exception.try' that takes a 'Prism' (or any 'Getter') to select which -- exceptions are caught (c.f. 'Control.Exception.tryJust', 'Control.Exception.catchJust'). If the -- '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 :: MonadCatchIO 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) -- | 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) ------------------------------------------------------------------------------ -- Throwing ------------------------------------------------------------------------------ -- | Throw an 'Exception' described by a 'Prism'. Exceptions may be thrown from -- purely functional code, but may only be caught within the 'IO' 'Monad'. -- -- @ -- 'throwing' l ≡ 'reviews' l 'throw' -- @ -- -- @ -- 'throwing' :: 'Prism'' 'SomeException' t -> t -> r -- 'throwing' :: 'Iso'' 'SomeException' t -> t -> r -- @ throwing :: AReview s SomeException a b -> b -> r throwing l = reviews l Exception.throw {-# 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 -- by a 'Prism'. -- -- Although 'throwingM' has a type that is a specialization of the type of -- 'throwing', the two functions are subtly different: -- -- @ -- 'throwing' l e \`seq\` x ≡ 'throwing' e -- 'throwingM' l e \`seq\` x ≡ x -- @ -- -- 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' -- 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. -- -- @ -- 'throwingM' l ≡ 'reviews' l 'CatchIO.throw' -- @ -- -- @ -- 'throwingM' :: 'MonadIO' m => 'Prism'' 'SomeException' t -> t -> m r -- 'throwingM' :: 'MonadIO' m => 'Iso'' 'SomeException' t -> t -> m r -- @ throwingM :: MonadIO m => AReview s SomeException a b -> b -> m r throwingM l = reviews l (liftIO . throwIO) {-# INLINE throwingM #-} -- | 'throwingTo' raises an 'Exception' specified by a 'Prism' in the target thread. -- -- @ -- 'throwingTo' thread l ≡ 'reviews' l ('throwTo' thread) -- @ -- -- @ -- 'throwingTo' :: 'ThreadId' -> 'Prism'' 'SomeException' t -> t -> m a -- 'throwingTo' :: 'ThreadId' -> 'Iso'' 'SomeException' t -> t -> m a -- @ throwingTo :: MonadIO m => ThreadId -> AReview s SomeException a b -> b -> m () throwingTo tid l = reviews l (liftIO . throwTo tid) {-# INLINE throwingTo #-} ---------------------------------------------------------------------------- -- IOException ---------------------------------------------------------------------------- -- | Exceptions that occur in the 'IO' 'Monad'. An 'IOException' records a -- more specific error type, a descriptive string and maybe the handle that was -- used when the error was flagged. -- -- Due to their richer structure relative to other exceptions, these have -- a more carefully overloaded signature. class AsIOException p f t where -- | Unfortunately the name 'ioException' is taken by @base@ for -- throwing IOExceptions. -- -- @ -- '_IOException' :: 'Equality'' '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 instance AsIOException p f IOException where _IOException = id {-# INLINE _IOException #-} instance (Choice p, Applicative f) => AsIOException p f SomeException where _IOException = exception {-# INLINE _IOException #-} ---------------------------------------------------------------------------- -- ArithException ---------------------------------------------------------------------------- -- | Arithmetic exceptions. class AsArithException p f t where -- '_ArithException' :: 'Equality'' 'ArithException' 'ArithException' -- '_ArithException' :: 'Prism'' 'SomeException' 'ArithException' _ArithException :: Overloaded' p f t ArithException instance AsArithException p f ArithException where _ArithException = id {-# INLINE _ArithException #-} instance (Choice p, Applicative f) => AsArithException p f SomeException where _ArithException = exception {-# INLINE _ArithException #-} -- | Handle arithmetic '_Overflow'. -- -- @ -- '_Overflow' ≡ '_ArithException' '.' '_Overflow' -- @ -- -- @ -- '_Overflow' :: 'Prism'' 'ArithException' 'ArithException' -- '_Overflow' :: 'Prism'' 'SomeException' 'ArithException' -- @ _Overflow :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t () _Overflow = _ArithException . dimap seta (either id id) . right' . rmap (Overflow <$) where seta Overflow = Right () seta t = Left (pure t) {-# INLINE _Overflow #-} -- | Handle arithmetic '_Underflow'. -- -- @ -- '_Underflow' ≡ '_ArithException' '.' '_Underflow' -- @ -- -- @ -- '_Underflow' :: 'Prism'' 'ArithException' 'ArithException' -- '_Underflow' :: 'Prism'' 'SomeException' 'ArithException' -- @ _Underflow :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t () _Underflow = _ArithException . dimap seta (either id id) . right' . rmap (Underflow <$) where seta Underflow = Right () seta t = Left (pure t) {-# INLINE _Underflow #-} -- | Handle arithmetic loss of precision. -- -- @ -- '_LossOfPrecision' ≡ '_ArithException' '.' '_LossOfPrecision' -- @ -- -- @ -- '_LossOfPrecision' :: 'Prism'' 'ArithException' 'ArithException' -- '_LossOfPrecision' :: 'Prism'' 'SomeException' 'ArithException' -- @ _LossOfPrecision :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t () _LossOfPrecision = _ArithException . dimap seta (either id id) . right' . rmap (LossOfPrecision <$) where seta LossOfPrecision = Right () seta t = Left (pure t) {-# INLINE _LossOfPrecision #-} -- | Handle division by zero. -- -- @ -- '_DivideByZero' ≡ '_ArithException' '.' '_DivideByZero' -- @ -- -- @ -- '_DivideByZero' :: 'Prism'' 'ArithException' 'ArithException' -- '_DivideByZero' :: 'Prism'' 'SomeException' 'ArithException' -- @ _DivideByZero :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f 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. -- -- @ -- '_Denormal' ≡ '_ArithException' '.' '_Denormal' -- @ -- -- @ -- '_Denormal' :: 'Prism'' 'ArithException' 'ArithException' -- '_Denormal' :: 'Prism'' 'SomeException' 'ArithException' -- @ _Denormal :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t () _Denormal = _ArithException . dimap seta (either id id) . right' . rmap (Denormal <$) where seta Denormal = Right () seta t = Left (pure t) {-# INLINE _Denormal #-} #if MIN_VERSION_base(4,6,0) -- | Added in @base@ 4.6 in response to this libraries discussion: -- -- -- -- @ -- '_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator' -- @ -- -- @ -- '_RatioZeroDenominator' :: 'Prism'' 'ArithException' 'ArithException' -- '_RatioZeroDenominator' :: 'Prism'' 'SomeException' 'ArithException' -- @ _RatioZeroDenominator :: (AsArithException p f t, Choice p, Applicative f) => Overloaded' p f t () _RatioZeroDenominator = _ArithException . dimap seta (either id id) . right' . rmap (RatioZeroDenominator <$) where seta RatioZeroDenominator = Right () seta t = Left (pure t) {-# INLINE _RatioZeroDenominator #-} #endif ---------------------------------------------------------------------------- -- ArrayException ---------------------------------------------------------------------------- -- | Exceptions generated by array operations. class AsArrayException p f t where -- | Extract information about an 'ArrayException'. -- -- @ -- '_ArrayException' :: 'Equality'' 'ArrayException' 'ArrayException' -- '_ArrayException' :: 'Prism'' 'SomeException' 'ArrayException' -- @ _ArrayException :: Overloaded' p f t ArrayException instance AsArrayException p f ArrayException where _ArrayException = id {-# INLINE _ArrayException #-} instance (Choice p, Applicative f) => AsArrayException p f SomeException where _ArrayException = exception {-# INLINE _ArrayException #-} -- | An attempt was made to index an array outside its declared bounds. -- -- @ -- '_IndexOutOfBounds' ≡ '_ArrayException' '.' '_IndexOutOfBounds' -- @ -- -- @ -- '_IndexOutOfBounds' :: 'Prism'' 'ArrayException' 'String' -- '_IndexOutOfBounds' :: 'Prism'' 'SomeException' 'String' -- @ _IndexOutOfBounds :: (AsArrayException p f t, Choice p, Applicative f) => Overloaded' p f t String _IndexOutOfBounds = _ArrayException . dimap seta (either id id) . right' . rmap (fmap IndexOutOfBounds) where seta (IndexOutOfBounds r) = Right r seta t = Left (pure t) {-# INLINE _IndexOutOfBounds #-} -- | An attempt was made to evaluate an element of an array that had not been initialized. -- -- @ -- '_UndefinedElement' ≡ '_ArrayException' '.' '_UndefinedElement' -- @ -- -- @ -- '_UndefinedElement' :: 'Prism'' 'ArrayException' 'String' -- '_UndefinedElement' :: 'Prism'' 'SomeException' 'String' -- @ _UndefinedElement :: (AsArrayException p f t, Choice p, Applicative f) => Overloaded' p f t String _UndefinedElement = _ArrayException . dimap seta (either id id) . right' . rmap (fmap UndefinedElement) where seta (UndefinedElement r) = Right r seta t = Left (pure t) {-# INLINE _UndefinedElement #-} ---------------------------------------------------------------------------- -- AssertionFailed ---------------------------------------------------------------------------- -- | 'assert' was applied to 'Prelude.False'. class AsAssertionFailed p f t where -- | This 'Exception' contains provides information about what assertion failed in the 'String'. -- -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("" `isInfixOf` xs) ) $ assert False (return "uncaught") -- "caught" -- -- @ -- '_AssertionFailed' :: 'Iso'' 'AssertionFailed' 'String' -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' -- @ _AssertionFailed :: Overloaded' p f t String instance (Profunctor p, Functor f) => AsAssertionFailed p f AssertionFailed where _AssertionFailed = unwrapping AssertionFailed {-# INLINE _AssertionFailed #-} instance (Choice p, Applicative f) => AsAssertionFailed p f SomeException where _AssertionFailed = exception.unwrapping AssertionFailed {-# INLINE _AssertionFailed #-} ---------------------------------------------------------------------------- -- AsyncException ---------------------------------------------------------------------------- -- | Asynchronous exceptions. class AsAsyncException p f t where -- | There are several types of 'AsyncException'. -- -- @ -- '_AsyncException' :: 'Equality'' 'AsyncException' 'AsyncException' -- '_AsyncException' :: 'Prism'' 'SomeException' 'AsyncException' -- @ _AsyncException :: Overloaded' p f t AsyncException instance AsAsyncException p f AsyncException where _AsyncException = id {-# INLINE _AsyncException #-} instance (Choice p, Applicative f) => AsAsyncException p f SomeException where _AsyncException = exception {-# INLINE _AsyncException #-} -- | The current thread's stack exceeded its limit. Since an 'Exception' has -- been raised, the thread's stack will certainly be below its limit again, -- but the programmer should take remedial action immediately. -- -- @ -- '_StackOverflow' :: 'Prism'' 'AsyncException' () -- '_StackOverflow' :: 'Prism'' 'SomeException' () -- @ _StackOverflow :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t () _StackOverflow = _AsyncException . dimap seta (either id id) . right' . rmap (StackOverflow <$) where seta StackOverflow = Right () seta t = Left (pure t) {-# INLINE _StackOverflow #-} -- | The program's heap is reaching its limit, and the program should take action -- to reduce the amount of live data it has. -- -- Notes: -- -- * It is undefined which thread receives this 'Exception'. -- -- * GHC currently does not throw 'HeapOverflow' exceptions. -- -- @ -- '_HeapOverflow' :: 'Prism'' 'AsyncException' () -- '_HeapOverflow' :: 'Prism'' 'SomeException' () -- @ _HeapOverflow :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t () _HeapOverflow = _AsyncException . dimap seta (either id id) . right' . rmap (HeapOverflow <$) where seta HeapOverflow = Right () seta t = Left (pure t) {-# INLINE _HeapOverflow #-} -- | This 'Exception' is raised by another thread calling -- 'Control.Concurrent.killThread', or by the system if it needs to terminate -- the thread for some reason. -- -- @ -- '_ThreadKilled' :: 'Prism'' 'AsyncException' () -- '_ThreadKilled' :: 'Prism'' 'SomeException' () -- @ _ThreadKilled :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t () _ThreadKilled = _AsyncException . dimap seta (either id id) . right' . rmap (ThreadKilled <$) where seta ThreadKilled = Right () seta t = Left (pure t) {-# INLINE _ThreadKilled #-} -- | This 'Exception' is raised by default in the main thread of the program when -- the user requests to terminate the program via the usual mechanism(s) -- (/e.g./ Control-C in the console). -- -- @ -- '_UserInterrupt' :: 'Prism'' 'AsyncException' () -- '_UserInterrupt' :: 'Prism'' 'SomeException' () -- @ _UserInterrupt :: (AsAsyncException p f t, Choice p, Applicative f) => Overloaded' p f t () _UserInterrupt = _AsyncException . dimap seta (either id id) . right' . rmap (UserInterrupt <$) where seta UserInterrupt = Right () seta t = Left (pure t) {-# INLINE _UserInterrupt #-} ---------------------------------------------------------------------------- -- AsyncException ---------------------------------------------------------------------------- -- | 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 -- | There is no additional information carried in a 'NonTermination' 'Exception'. -- -- @ -- '_NonTermination' :: 'Iso'' 'NonTermination' () -- '_NonTermination' :: 'Prism'' 'SomeException' () -- @ _NonTermination :: Overloaded' p f t () instance (Profunctor p, Functor f) => AsNonTermination p f NonTermination where _NonTermination = trivial NonTermination {-# INLINE _NonTermination #-} instance (Choice p, Applicative f) => AsNonTermination p f SomeException where _NonTermination = exception.trivial NonTermination {-# INLINE _NonTermination #-} ---------------------------------------------------------------------------- -- NestedAtomically ---------------------------------------------------------------------------- -- | 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 -- | There is no additional information carried in a 'NestedAtomically' 'Exception'. -- -- @ -- '_NestedAtomically' :: 'Iso'' 'NestedAtomically' () -- '_NestedAtomically' :: 'Prism'' 'SomeException' () -- @ _NestedAtomically :: Overloaded' p f t () instance (Profunctor p, Functor f) => AsNestedAtomically p f NestedAtomically where _NestedAtomically = trivial NestedAtomically {-# INLINE _NestedAtomically #-} instance (Choice p, Applicative f) => AsNestedAtomically p f SomeException where _NestedAtomically = exception.trivial NestedAtomically {-# INLINE _NestedAtomically #-} ---------------------------------------------------------------------------- -- BlockedIndefinitelyOnMVar ---------------------------------------------------------------------------- -- | 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 -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'. -- -- @ -- '_BlockedIndefinitelyOnMVar' :: 'Iso'' 'BlockedIndefinitelyOnMVar' () -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'SomeException' () -- @ _BlockedIndefinitelyOnMVar :: Overloaded' p f t () instance (Profunctor p, Functor f) => AsBlockedIndefinitelyOnMVar p f BlockedIndefinitelyOnMVar where _BlockedIndefinitelyOnMVar = trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} instance (Choice p, Applicative f) => AsBlockedIndefinitelyOnMVar p f SomeException where _BlockedIndefinitelyOnMVar = exception.trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} ---------------------------------------------------------------------------- -- BlockedIndefinitelyOnSTM ---------------------------------------------------------------------------- -- | 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 -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'. -- -- @ -- '_BlockedIndefinitelyOnSTM' :: 'Iso'' 'BlockedIndefinitelyOnSTM' () -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'SomeException' () -- @ _BlockedIndefinitelyOnSTM :: Overloaded' p f t () instance (Profunctor p, Functor f) => AsBlockedIndefinitelyOnSTM p f BlockedIndefinitelyOnSTM where _BlockedIndefinitelyOnSTM = trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} instance (Choice p, Applicative f) => AsBlockedIndefinitelyOnSTM p f SomeException where _BlockedIndefinitelyOnSTM = exception.trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} ---------------------------------------------------------------------------- -- Deadlock ---------------------------------------------------------------------------- -- | 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 -- | There is no information carried in a 'Deadlock' 'Exception'. -- -- @ -- '_Deadlock' :: 'Iso'' 'Deadlock' () -- '_Deadlock' :: 'Prism'' 'SomeException' () -- @ _Deadlock :: Overloaded' p f t () instance (Profunctor p, Functor f) => AsDeadlock p f Deadlock where _Deadlock = trivial Deadlock {-# INLINE _Deadlock #-} instance (Choice p, Applicative f) => AsDeadlock p f SomeException where _Deadlock = exception.trivial Deadlock {-# INLINE _Deadlock #-} ---------------------------------------------------------------------------- -- NoMethodError ---------------------------------------------------------------------------- -- | 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 -- | Extract a description of the missing method. -- -- @ -- '_NoMethodError' :: 'Iso'' 'NoMethodError' 'String' -- '_NoMethodError' :: 'Prism'' 'SomeException' 'String' -- @ _NoMethodError :: Overloaded' p f t String instance (Profunctor p, Functor f) => AsNoMethodError p f NoMethodError where _NoMethodError = unwrapping NoMethodError {-# INLINE _NoMethodError #-} instance (Choice p, Applicative f) => AsNoMethodError p f SomeException where _NoMethodError = exception.unwrapping NoMethodError {-# INLINE _NoMethodError #-} ---------------------------------------------------------------------------- -- PatternMatchFail ---------------------------------------------------------------------------- -- | A pattern match failed. class (Profunctor p, Functor f) => AsPatternMatchFail p f t where -- | Information about the source location of the pattern. -- -- @ -- '_PatternMatchFail' :: 'Iso'' 'PatternMatchFail' 'String' -- '_PatternMatchFail' :: 'Prism'' 'SomeException' 'String' -- @ _PatternMatchFail :: Overloaded' p f t String instance (Profunctor p, Functor f) => AsPatternMatchFail p f PatternMatchFail where _PatternMatchFail = unwrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} instance (Choice p, Applicative f) => AsPatternMatchFail p f SomeException where _PatternMatchFail = exception.unwrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} ---------------------------------------------------------------------------- -- RecConError ---------------------------------------------------------------------------- -- | An uninitialised record field was used. class (Profunctor p, Functor f) => AsRecConError p f t where -- | Information about the source location where the record was -- constructed. -- -- @ -- '_RecConError' :: 'Iso'' 'RecConError' 'String' -- '_RecConError' :: 'Prism'' 'SomeException' 'String' -- @ _RecConError :: Overloaded' p f t String instance (Profunctor p, Functor f) => AsRecConError p f RecConError where _RecConError = unwrapping RecConError {-# INLINE _RecConError #-} instance (Choice p, Applicative f) => AsRecConError p f SomeException where _RecConError = exception.unwrapping RecConError {-# INLINE _RecConError #-} ---------------------------------------------------------------------------- -- RecSelError ---------------------------------------------------------------------------- -- | 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 -- | Information about the source location where the record selection occurred. _RecSelError :: Overloaded' p f t String instance (Profunctor p, Functor f) => AsRecSelError p f RecSelError where _RecSelError = unwrapping RecSelError {-# INLINE _RecSelError #-} instance (Choice p, Applicative f) => AsRecSelError p f SomeException where _RecSelError = exception.unwrapping RecSelError {-# INLINE _RecSelError #-} ---------------------------------------------------------------------------- -- RecUpdError ---------------------------------------------------------------------------- -- | 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 -- | Information about the source location where the record was updated. _RecUpdError :: Overloaded' p f t String instance (Profunctor p, Functor f) => AsRecUpdError p f RecUpdError where _RecUpdError = unwrapping RecUpdError {-# INLINE _RecUpdError #-} instance (Choice p, Applicative f) => AsRecUpdError p f SomeException where _RecUpdError = exception.unwrapping RecUpdError {-# INLINE _RecUpdError #-} ---------------------------------------------------------------------------- -- ErrorCall ---------------------------------------------------------------------------- -- | This is thrown when the user calls 'Prelude.error'. class (Profunctor p, Functor f) => AsErrorCall p f 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 instance (Profunctor p, Functor f) => AsErrorCall p f ErrorCall where _ErrorCall = unwrapping ErrorCall {-# INLINE _ErrorCall #-} instance (Choice p, Applicative f) => AsErrorCall p f SomeException where _ErrorCall = exception.unwrapping ErrorCall {-# INLINE _ErrorCall #-} ------------------------------------------------------------------------------ -- HandlingException ------------------------------------------------------------------------------ -- | 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 -- | There is no information carried in a 'HandlingException'. -- -- @ -- '_HandlingException' :: 'Iso'' 'HandlingException' () -- '_HandlingException' :: 'Prism'' 'SomeException' () -- @ _HandlingException :: Overloaded' p f t () instance (Profunctor p, Functor f) => AsHandlingException p f HandlingException where _HandlingException = trivial HandlingException {-# INLINE _HandlingException #-} instance (Choice p, Applicative f) => AsHandlingException p f SomeException where _HandlingException = exception.trivial HandlingException {-# INLINE _HandlingException #-} ------------------------------------------------------------------------------ -- Helper Functions ------------------------------------------------------------------------------ trivial :: t -> Iso' t () trivial t = const () `iso` const t lens-3.10/src/Control/Lens/0000755000000000000000000000000012226700613013673 5ustar0000000000000000lens-3.10/src/Control/Lens/Action.hs0000644000000000000000000001256212226700613015452 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Action -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Action ( -- * Composable Actions Action , act , acts , perform , performs , liftAct , (^!) , (^!!) , (^!?) -- * Indexed Actions , IndexedAction , iact , iperform , iperforms , (^@!) , (^@!!) , (^@!?) -- * Folds with Effects , MonadicFold , IndexedMonadicFold -- * Implementation Details , Acting , IndexedActing , Effective ) where import Control.Comonad import Control.Lens.Internal.Action import Control.Lens.Internal.Fold import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad (liftM) import Control.Monad.Trans.Class import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!? -- | Used to evaluate an 'Action'. type Acting m r s t a b = LensLike (Effect m r) s t a b -- | Perform an 'Action'. -- -- @ -- 'perform' ≡ 'flip' ('^!') -- @ perform :: Monad m => Acting m a s t a b -> 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 :: (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) {-# INLINE performs #-} -- | Perform an 'Action'. -- -- >>> ["hello","world"]^!folded.act putStrLn -- hello -- world (^!) :: Monad m => s -> Acting m a s t a b -> m a a ^! l = getEffect (l (Effect #. return) a) {-# INLINE (^!) #-} -- | Perform a 'MonadicFold' and collect all of the results in a list. -- -- >>> ["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] a ^!! l = getEffect (l (Effect #. return . return) a) {-# INLINE (^!!) #-} -- | Perform a 'MonadicFold' and collect the leftmost result. -- -- /Note:/ this still causes all effects for all elements. -- -- >>> [Just 1, Just 2, Just 3]^!?folded.acts -- Just (Just 1) -- >>> [Just 1, Nothing]^!?folded.acts -- Nothing (^!?) :: Monad m => s -> Acting m (Leftmost a) s t a b -> m (Maybe a) a ^!? l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) a {-# INLINE (^!?) #-} -- | Construct an 'Action' from a monadic side-effect. -- -- >>> ["hello","world"]^!folded.act (\x -> [x,x ++ "!"]) -- ["helloworld","helloworld!","hello!world","hello!world!"] -- -- @ -- 'act' :: 'Monad' m => (s -> m a) -> 'Action' m s a -- 'act' sma afb a = 'effective' (sma a '>>=' 'ineffective' '.' afb) -- @ act :: Monad m => (s -> m a) -> IndexPreservingAction m s a act sma pafb = cotabulate $ \ws -> effective $ do a <- sma (extract ws) ineffective (corep pafb (a <$ ws)) {-# INLINE act #-} -- | A self-running 'Action', analogous to 'Control.Monad.join'. -- -- @ -- 'acts' ≡ 'act' 'id' -- @ -- -- >>> (1,"hello")^!_2.acts.to succ -- "ifmmp" acts :: Action 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 l = act (lift . perform l) {-# INLINE liftAct #-} ----------------------------------------------------------------------------- -- Indexed Actions ---------------------------------------------------------------------------- -- | Used to evaluate an 'IndexedAction'. type IndexedActing i m r s t a b = Over (Indexed i) (Effect m r) s t a b -- | Perform an 'IndexedAction'. -- -- @ -- 'iperform' ≡ 'flip' ('^@!') -- @ iperform :: Monad m => IndexedActing i m (i, a) s t a b -> 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 l = performs l .# Indexed {-# INLINE iperforms #-} -- | Perform an 'IndexedAction'. (^@!) :: Monad m => s -> IndexedActing i m (i, a) s t a b -> 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)] 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)) a ^@!? l = liftM getLeftmost .# getEffect $ l (Indexed $ \i -> Effect #. return . LLeaf . (,) i) a {-# INLINE (^@!?) #-} -- | Construct an 'IndexedAction' from a monadic side-effect. iact :: Monad m => (s -> m (i, a)) -> IndexedAction i m s a iact smia iafb s = effective $ do (i, a) <- smia s ineffective (indexed iafb i a) {-# INLINE iact #-} lens-3.10/src/Control/Lens/At.hs0000644000000000000000000004660212226700613014603 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.At -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.At ( -- * At At(at), sans -- * Ixed , IxValue , Ixed(ix) , ixAt, ixEach -- * 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.Setter import Control.Lens.Type import Control.Lens.Traversal 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.IntMap as IntMap import Data.IntSet as IntSet 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.Tree import Data.Vector as Vector hiding (indexed) import Data.Vector.Primitive as Prim import Data.Vector.Storable as Storable import Data.Vector.Unboxed as Unboxed import Data.Word -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- | 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 -- | -- >>> IntSet.fromList [1,2,3,4] ^. contains 3 -- True -- -- >>> IntSet.fromList [1,2,3,4] ^. contains 5 -- False -- -- >>> 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 #-} instance Functor f => Contains f IntSet where contains k f s = Lens.indexed f k (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 -> 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 -> 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 -- 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 -- 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 -- 'Lens' if it is already present. -- -- If you want to be able to insert /missing/ values, you want 'at'. -- -- >>> Seq.fromList [a,b,c,d] & ix 2 %~ f -- fromList [a,b,f c,d] -- -- >>> Seq.fromList [a,b,c,d] & ix 2 .~ e -- fromList [a,b,e,d] -- -- >>> Seq.fromList [a,b,c,d] ^? ix 2 -- Just c -- -- >>> Seq.fromList [] ^? ix 2 -- Nothing ix :: Index m -> IndexedLensLike' (Index m) f m (IxValue m) #ifdef DEFAULT_SIGNATURES default ix :: (Applicative f, At m) => Index m -> IndexedLensLike' (Index m) 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 {-# 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 [a] = a instance Applicative f => Ixed f [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) i = (a:) <$> (go as $! i - 1) {-# 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 {-# INLINE ix #-} type instance IxValue (Tree a) = a instance Applicative f => Ixed f (Tree a) where ix xs0 f = go xs0 where go [] (Node a as) = Lens.indexed f xs0 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) goto is (_:as) n = goto is as $! n - 1 goto _ [] _ = pure [] {-# INLINE ix #-} type instance IxValue (Seq a) = a instance Applicative f => Ixed f (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 | otherwise = pure m {-# INLINE ix #-} type instance IxValue (IntMap a) = a instance Applicative f => Ixed f (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 Nothing -> pure m {-# INLINE ix #-} type instance IxValue (Map k a) = a instance (Applicative f, Ord k) => Ixed f (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 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 ix k f m = case HashMap.lookup k m of Just v -> Lens.indexed f k v <&> \v' -> HashMap.insert k v' m Nothing -> 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 ix i f arr | inRange (bounds arr) i = Lens.indexed f i (arr Array.! i) <&> \e -> arr Array.// [(i,e)] | otherwise = pure arr {-# INLINE ix #-} type instance IxValue (UArray i e) = e -- | -- @ -- 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 ix i f arr | inRange (bounds arr) i = Lens.indexed f i (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 ix i f v | 0 <= i && i < Vector.length v = Lens.indexed f i (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 ix i f v | 0 <= i && i < Prim.length v = Lens.indexed f i (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 ix i f v | 0 <= i && i < Storable.length v = Lens.indexed f i (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 ix i f v | 0 <= i && i < Unboxed.length v = Lens.indexed f i (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 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] {-# INLINE ix #-} type instance IxValue LazyT.Text = Char instance Applicative f => Ixed f 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) {-# INLINE ix #-} type instance IxValue StrictB.ByteString = Word8 instance Applicative f => Ixed f 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] {-# INLINE ix #-} type instance IxValue LazyB.ByteString = Word8 instance Applicative f => Ixed f 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) {-# 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. -- -- An instance of 'At' should satisfy: -- -- @ -- 'ix' k ≡ 'at' k '<.' 'traverse' -- @ class At m where -- | -- >>> Map.fromList [(1,"world")] ^.at 1 -- Just "world" -- -- >>> at 1 ?~ "hello" $ Map.empty -- fromList [(1,"hello")] -- -- /Note:/ 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where -- you cannot satisfy the 'Lens' laws. at :: Index m -> IndexedLens' (Index m) m (Maybe (IxValue m)) sans :: At m => Index m -> m -> m sans k m = m & at k .~ Nothing {-# INLINE sans #-} instance At (IntMap a) where at k f m = Lens.indexed f k 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 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 Nothing -> maybe m (const (HashMap.delete k m)) mv Just v' -> HashMap.insert k v' m where mv = HashMap.lookup k m {-# INLINE at #-} lens-3.10/src/Control/Lens/Combinators.hs0000644000000000000000000000414612226700613016514 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Combinators -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- These are general purpose combinators that provide utility for non-lens code ------------------------------------------------------------------------------- module Control.Lens.Combinators ( (&) , (<&>) , (??) ) 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 (??) #-} lens-3.10/src/Control/Lens/Cons.hs0000644000000000000000000003252712226700613015142 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Cons -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.Cons ( -- * Cons Cons(..) , (<|) , cons , uncons , _head, _tail -- * Snoc , Snoc(..) , (|>) , snoc , unsnoc , _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 import qualified Data.Text.Lazy as LazyT import Data.Vector (Vector) import qualified Data.Vector as Vector import Data.Vector.Storable (Storable) import qualified Data.Vector.Storable as Storable import Data.Vector.Primitive (Prim) import qualified Data.Vector.Primitive as Prim import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox import Data.Word -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g infixr 5 <|, `cons` infixl 5 |>, `snoc` ------------------------------------------------------------------------------ -- Cons ------------------------------------------------------------------------------ -- | 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'. -- -- @ -- '_Cons' :: 'Prism' [a] [b] (a, [a]) (b, [b]) -- '_Cons' :: 'Prism' ('Seq' a) ('Seq' b) (a, 'Seq' a) (b, 'Seq' b) -- '_Cons' :: 'Prism' ('Vector' a) ('Vector' b) (a, 'Vector' a) (b, 'Vector' b) -- '_Cons' :: 'Prism'' 'String' ('Char', 'String') -- '_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) instance (Choice p, Applicative f) => Cons p f [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 _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 _Cons = prism' (uncurry StrictB.cons) StrictB.uncons instance (Choice p, Applicative f) => Cons p f LazyB.ByteString LazyB.ByteString Word8 Word8 where _Cons = prism' (uncurry LazyB.cons) LazyB.uncons instance (Choice p, Applicative f) => Cons p f StrictT.Text StrictT.Text Char Char where _Cons = prism' (uncurry StrictT.cons) StrictT.uncons instance (Choice p, Applicative f) => Cons p f LazyT.Text LazyT.Text Char Char where _Cons = prism' (uncurry LazyT.cons) LazyT.uncons instance (Choice p, Applicative f) => Cons p f (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 _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 _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 _Cons = prism (uncurry Unbox.cons) $ \v -> if Unbox.null v then Left Unbox.empty else Right (Unbox.unsafeHead v, Unbox.unsafeTail v) {-# INLINE _Cons #-} -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'. (<|) :: Cons Reviewed Identity 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 = 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 = simply preview _Cons {-# INLINE uncons #-} -- | A 'Traversal' reading and writing to the 'head' of a /non-empty/ container. -- -- >>> [a,b,c]^? _head -- Just a -- -- >>> [a,b,c] & _head .~ d -- [d,b,c] -- -- >>> [a,b,c] & _head %~ f -- [f a,b,c] -- -- >>> [] & _head %~ f -- [] -- -- >>> [1,2,3]^?!_head -- 1 -- -- >>> []^?_head -- Nothing -- -- >>> [1,2]^?_head -- Just 1 -- -- >>> [] & _head .~ 1 -- [] -- -- >>> [0] & _head .~ 2 -- [2] -- -- >>> [0,1] & _head .~ 2 -- [2,1] -- -- This isn't limited to lists. -- -- For instance you can also 'Data.Traversable.traverse' the head of a 'Seq': -- -- >>> Seq.fromList [a,b,c,d] & _head %~ f -- fromList [f a,b,c,d] -- -- >>> Seq.fromList [] ^? _head -- Nothing -- -- >>> Seq.fromList [a,b,c,d] ^? _head -- Just a -- -- @ -- '_head' :: 'Traversal'' [a] a -- '_head' :: 'Traversal'' ('Seq' a) a -- '_head' :: 'Traversal'' ('Vector' a) a -- @ _head :: Cons (->) f s s a a => LensLike' f s a _head = _Cons._1 {-# INLINE _head #-} -- | A 'Traversal' reading and writing to the 'tail' of a /non-empty/ container. -- -- >>> [a,b] & _tail .~ [c,d,e] -- [a,c,d,e] -- -- >>> [] & _tail .~ [a,b] -- [] -- -- >>> [a,b,c,d,e] & _tail.traverse %~ f -- [a,f b,f c,f d,f e] -- -- >>> [1,2] & _tail .~ [3,4,5] -- [1,3,4,5] -- -- >>> [] & _tail .~ [1,2] -- [] -- -- >>> [a,b,c]^?_tail -- Just [b,c] -- -- >>> [1,2]^?!_tail -- [2] -- -- >>> "hello"^._tail -- "ello" -- -- >>> ""^._tail -- "" -- -- This isn't limited to lists. For instance you can also 'Control.Traversable.traverse' the tail of a 'Seq'. -- -- >>> Seq.fromList [a,b] & _tail .~ Seq.fromList [c,d,e] -- fromList [a,c,d,e] -- -- >>> Seq.fromList [a,b,c] ^? _tail -- Just (fromList [b,c]) -- -- >>> Seq.fromList [] ^? _tail -- Nothing -- -- @ -- '_tail' :: 'Traversal'' [a] [a] -- '_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._2 {-# INLINE _tail #-} ------------------------------------------------------------------------------ -- Snoc ------------------------------------------------------------------------------ -- | 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'. -- -- @ -- '_Snoc' :: 'Prism' [a] [b] ([a], a) ([b], b) -- '_Snoc' :: 'Prism' ('Seq' a) ('Seq' b) ('Seq' a, a) ('Seq' b, b) -- '_Snoc' :: 'Prism' ('Vector' a) ('Vector' b) ('Vector' a, a) ('Vector' b, b) -- '_Snoc' :: 'Prism'' 'String' ('String', 'Char') -- '_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) instance (Choice p, Applicative f) => Snoc p f [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 _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 _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 _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 _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 _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 _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 _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 _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 _Snoc = prism (uncurry LazyT.snoc) $ \v -> if LazyT.null v then Left LazyT.empty else Right (LazyT.init v, LazyT.last v) {-# INLINE _Snoc #-} -- | A 'Traversal' reading and replacing all but the a last element of a /non-empty/ container. -- -- >>> [a,b,c,d]^?_init -- Just [a,b,c] -- -- >>> []^?_init -- Nothing -- -- >>> [a,b] & _init .~ [c,d,e] -- [c,d,e,b] -- -- >>> [] & _init .~ [a,b] -- [] -- -- >>> [a,b,c,d] & _init.traverse %~ f -- [f a,f b,f c,d] -- -- >>> [1,2,3]^?_init -- Just [1,2] -- -- >>> [1,2,3,4]^?!_init -- [1,2,3] -- -- >>> "hello"^._init -- "hell" -- -- >>> ""^._init -- "" -- -- @ -- '_init' :: 'Traversal'' [a] [a] -- '_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._1 {-# INLINE _init #-} -- | A 'Traversal' reading and writing to the last element of a /non-empty/ container. -- -- >>> [a,b,c]^?!_last -- c -- -- >>> []^?_last -- Nothing -- -- >>> [a,b,c] & _last %~ f -- [a,b,f c] -- -- >>> [1,2]^?_last -- Just 2 -- -- >>> [] & _last .~ 1 -- [] -- -- >>> [0] & _last .~ 2 -- [2] -- -- >>> [0,1] & _last .~ 2 -- [0,2] -- -- This 'Traversal' is not limited to lists, however. We can also work with other containers, such as a 'Vector'. -- -- >>> Vector.fromList "abcde" ^? _last -- Just 'e' -- -- >>> Vector.empty ^? _last -- Nothing -- -- >>> Vector.fromList "abcde" & _last .~ 'Q' -- fromList "abcdQ" -- -- @ -- '_last' :: 'Traversal'' [a] a -- '_last' :: 'Traversal'' ('Seq' a) a -- '_last' :: 'Traversal'' ('Vector' a) a -- @ _last :: Snoc (->) f s s a a => LensLike' f 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 (|>) = 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 = 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 s = simply preview _Snoc s {-# INLINE unsnoc #-} lens-3.10/src/Control/Lens/Each.hs0000644000000000000000000003112212226700613015066 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# 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 -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.Each ( -- * Indices Index -- * 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 import Data.Array.Unboxed as Unboxed import Data.Array.IArray as IArray 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.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 import Data.Vector.Primitive (Prim) import qualified Data.Vector.Storable as Storable import Data.Vector.Storable (Storable) import qualified Data.Vector.Unboxed as Unboxed 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 -- >>> import Data.Text.Strict.Lens as Text -- >>> import Data.Char as Char -- | Extract 'each' element of a (potentially monomorphic) container. -- -- Notably, when applied to a tuple, this generalizes 'Control.Lens.Traversal.both' to arbitrary homogeneous tuples. -- -- >>> (1,2,3) & each *~ 10 -- (10,20,30) -- -- It can also be used on monomorphic containers like 'StrictT.Text' or 'StrictB.ByteString'. -- -- >>> 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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' :: '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' :: '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' :: 'IndexedTraversal' 'Int' [a] [b] a b@ instance Applicative f => Each f [a] [b] a b where each = traversed {-# INLINE each #-} -- | @'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' :: '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' :: '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' :: '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' :: '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' :: ('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' :: ('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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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 {-# 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) {-# 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) {-# 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)) {-# INLINE each #-} lens-3.10/src/Control/Lens/Equality.hs0000644000000000000000000000443212226700613016027 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Equality -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Control.Lens.Equality ( -- * Type Equality Equality, Equality' , AnEquality, AnEquality' , runEq , substEq , mapEq , fromEq , simply -- * Implementation Details , Identical(..) ) where import Control.Lens.Internal.Setter import Control.Lens.Type {-# ANN module "HLint: ignore Use id" #-} {-# ANN module "HLint: ignore Eta reduce" #-} -- $setup -- >>> import Control.Lens ----------------------------------------------------------------------------- -- Equality ----------------------------------------------------------------------------- -- | Provides witness that @(s ~ a, b ~ t)@ holds. data Identical a b s t where 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) -- | A 'Simple' 'AnEquality'. type AnEquality' s a = AnEquality s s a a -- | Extract a witness of type 'Equality'. runEq :: AnEquality s t a b -> Identical s t a b runEq l = case l Identical of Identical -> Identical {-# INLINE runEq #-} -- | Substituting types with 'Equality'. substEq :: AnEquality s t a b -> ((s ~ a, t ~ b) => r) -> r substEq l = case runEq l of Identical -> \r -> r {-# INLINE substEq #-} -- | We can use 'Equality' to do substitution into anything. mapEq :: AnEquality s t a b -> f s -> f a mapEq l r = substEq l r {-# INLINE mapEq #-} -- | 'Equality' is symmetric. fromEq :: AnEquality s t a b -> Equality b a t s fromEq l = substEq l id {-# INLINE fromEq #-} -- | 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 = id {-# INLINE simply #-} lens-3.10/src/Control/Lens/Fold.hs0000644000000000000000000024053012226700613015117 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- A @'Fold' s a@ is a generalization of something 'Foldable'. It allows -- you to extract multiple results from a container. A 'Foldable' container -- can be characterized by the behavior of -- @'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 -- -- @type 'Fold' s a = forall m. 'Monoid' m => 'Getting' m s a@ -- -- Every 'Getter' is a valid 'Fold' that simply doesn't use the 'Monoid' -- it is passed. -- -- In practice the type we use is slightly more complicated to allow for -- better error messages and for it to be transformed by certain -- 'Applicative' transformers. -- -- Everything you can do with a 'Foldable' container, you can with with a 'Fold' and there are -- combinators that generalize the usual 'Foldable' operations here. ---------------------------------------------------------------------------- module Control.Lens.Fold ( -- * Folds Fold , IndexedFold -- * Getting Started , (^..) , (^?) , (^?!) , pre, ipre , preview, previews, ipreview, ipreviews , preuse, preuses, ipreuse, ipreuses , has, hasn't -- ** Building Folds , folding , folded , unfolded , iterated , filtered , backwards , repeated , replicated , cycled , takingWhile , droppingWhile -- ** Folding , foldMapOf, foldOf , foldrOf, foldlOf , toListOf , anyOf, allOf , andOf, orOf , productOf, sumOf , traverseOf_, forOf_, sequenceAOf_ , mapMOf_, forMOf_, sequenceOf_ , asumOf, msumOf , concatMapOf, concatOf , elemOf, notElemOf , lengthOf , nullOf, notNullOf , firstOf, lastOf , maximumOf, minimumOf , maximumByOf, minimumByOf , findOf , foldrOf', foldlOf' , foldr1Of, foldl1Of , foldr1Of', foldl1Of' , foldrMOf, foldlMOf -- * Indexed Folds , (^@..) , (^@?) , (^@?!) -- ** Indexed Folding , ifoldMapOf , ifoldrOf , ifoldlOf , ianyOf , iallOf , itraverseOf_ , iforOf_ , imapMOf_ , iforMOf_ , iconcatMapOf , ifindOf , ifoldrOf' , ifoldlOf' , ifoldrMOf , ifoldlMOf , itoListOf -- ** Building Indexed Folds , ifiltered , itakingWhile , idroppingWhile -- * Deprecated , headOf -- * Internal types , Leftmost , Rightmost , Traversed , Sequenced ) where import Control.Applicative as Applicative import Control.Applicative.Backwards import Control.Comonad import Control.Lens.Getter import Control.Lens.Internal.Fold import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Internal.Magma import Control.Lens.Type import Control.Monad as Monad import Control.Monad.Reader import Control.Monad.State import Data.Foldable as Foldable import Data.Functor.Compose import Data.Maybe import Data.Monoid import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Data.Traversable -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Function -- >>> import Data.List.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate) -- >>> import Data.Maybe (fromMaybe) -- >>> import System.Timeout (timeout) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Use camelCase" #-} {-# ANN module "HLint: ignore Use curry" #-} infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! -------------------------- -- Folds -------------------------- -- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result. -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -- -- >>> [1,2,3,4]^..folding tail -- [2,3,4] folding :: (Foldable f, Contravariant g, Applicative g) => (s -> f a) -> LensLike g s t a b folding sfa agb = coerce . traverse_ agb . sfa {-# INLINE folding #-} -- | Obtain a 'Fold' from any 'Foldable'. -- -- >>> Just 3^..folded -- [3] -- -- >>> Nothing^..folded -- [] -- -- >>> [(1,2),(3,4)]^..folded.both -- [1,2,3,4] folded :: Foldable f => Fold (f a) a folded f = coerce . getFolding . foldMap (Folding #. f) {-# INLINE folded #-} -- | 'Fold' by repeating the input forever. -- -- @ -- 'repeat' ≡ 'toListOf' 'repeated' -- @ -- -- >>> 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 {-# INLINE repeated #-} -- | A 'Fold' that replicates its input @n@ times. -- -- @ -- 'replicate' n ≡ 'toListOf' ('replicated' n) -- @ -- -- >>> 5^..replicated 20 -- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] replicated :: Int -> Fold a a replicated n0 f a = go n0 where m = f a go 0 = noEffect go n = m *> go (n - 1) {-# INLINE replicated #-} -- | Transform a 'Fold' into a 'Fold' 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 {-# INLINE cycled #-} -- | Build a 'Fold' that unfolds its values from a seed. -- -- @ -- 'Prelude.unfoldr' ≡ 'toListOf' '.' 'unfolded' -- @ -- -- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1)) -- [10,9,8,7,6,5,4,3,2,1] unfolded :: (b -> Maybe (a, b)) -> Fold b a unfolded f g b0 = go b0 where go b = case f b of Just (a, b') -> g a *> go b' Nothing -> noEffect {-# INLINE unfolded #-} -- | @x '^.' 'iterated' f@ returns an infinite 'Fold' of repeated applications of @f@ to @x@. -- -- @ -- 'toListOf' ('iterated' f) a ≡ 'iterate' f a -- @ iterated :: (a -> a) -> Fold a a iterated f g a0 = go a0 where 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'). -- -- Note: This is /not/ a legal 'Traversal', 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. -- -- As a counter example, consider that given @evens = 'filtered' 'even'@ the second 'Traversal' law is violated: -- -- @ -- '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! -- -- >>> [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 p = dimap (\x -> if p x then Right x else Left x) (either pure id) . right' {-# INLINE filtered #-} -- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. -- -- @ -- 'takeWhile' p ≡ 'toListOf' ('takingWhile' p 'folded') -- @ -- -- >>> timingOut $ toListOf (takingWhile (<=3) folded) [1..] -- [1,2,3] -- -- @ -- 'takingWhile' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s a -- 'takingWhile' :: (a -> 'Bool') -> 'Getter' s a -> 'Fold' s a -- 'takingWhile' :: (a -> 'Bool') -> 'Traversal'' s a -> 'Fold' s a -- * See note below -- 'takingWhile' :: (a -> 'Bool') -> 'Lens'' s a -> 'Fold' s a -- * See note below -- 'takingWhile' :: (a -> 'Bool') -> 'Prism'' s a -> 'Fold' s a -- * See note below -- 'takingWhile' :: (a -> 'Bool') -> 'Iso'' s a -> 'Fold' s a -- * See note below -- 'takingWhile' :: (a -> 'Bool') -> 'Action' m s a -> 'MonadicFold' m s a -- 'takingWhile' :: (a -> 'Bool') -> 'MonadicFold' m s a -> 'MonadicFold' m s a -- 'takingWhile' :: (a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- * See note below -- 'takingWhile' :: (a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- * See note below -- 'takingWhile' :: (a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'takingWhile' :: (a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'takingWhile' :: (a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedMonadicFold' i m s a -- 'takingWhile' :: (a -> 'Bool') -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- @ -- -- /Note:/ When applied to a 'Traversal', 'takingWhile' yields something that can be used as if it were a 'Traversal', but -- which is not a 'Traversal' per the laws, unless you are careful to ensure that you do not invalidate the predicate when -- writing back through it. takingWhile :: (Conjoined p, Applicative f) => (a -> Bool) -> Over p (TakingWhile p f a a) s t a a -> Over p f s t a a takingWhile p l pafb = fmap runMagma . traverse (corep pafb) . runTakingWhile . l flag where flag = cotabulate $ \wa -> let a = extract wa; r = p a in TakingWhile r a $ \pr -> if pr && r then Magma () wa else MagmaPure a {-# INLINE takingWhile #-} -- | Obtain a 'Fold' by dropping elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. -- -- @ -- 'dropWhile' p ≡ 'toListOf' ('droppingWhile' p 'folded') -- @ -- -- >>> toListOf (droppingWhile (<=3) folded) [1..6] -- [4,5,6] -- -- >>> toListOf (droppingWhile (<=3) folded) [1,6,1] -- [6,1] -- -- @ -- 'droppingWhile' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s a -- 'droppingWhile' :: (a -> 'Bool') -> 'Getter' s a -> 'Fold' s a -- 'droppingWhile' :: (a -> 'Bool') -> 'Traversal'' s a -> 'Fold' s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'Lens'' s a -> 'Fold' s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'Prism'' s a -> 'Fold' s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'Iso'' s a -> 'Fold' s a -- see notes -- @ -- -- @ -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingTraversal'' s a -> 'IndexPreservingFold' s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingLens'' s a -> 'IndexPreservingFold' s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingGetter' s a -> 'IndexPreservingFold' s a -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingFold' s a -> 'IndexPreservingFold' s a -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingAction' m s a -> 'IndexPreservingFold' s a -- @ -- -- @ -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingMonadicFold' m s a -> 'IndexPreservingMonadicFold' m s a -- @ -- -- @ -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedFold' i s a -- @ -- -- @ -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- @ -- -- Note: Many uses of this combinator will yield something that meets the types, but not the laws of a valid -- 'Traversal' or 'IndexedTraversal'. The 'Traversal' and 'IndexedTraversal' laws are only satisfied if the -- new values you assign also pass the predicate! Otherwise subsequent traversals will visit fewer elements -- 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 droppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where g = cotabulate $ \wa -> Compose $ state $ \b -> let a = extract wa b' = b && p a in (if b' then pure a else corep f wa, b') {-# INLINE droppingWhile #-} -------------------------- -- Fold/Getter combinators -------------------------- -- | @ -- 'Data.Foldable.foldMap' = 'foldMapOf' 'folded' -- @ -- -- @ -- 'foldMapOf' ≡ 'views' -- 'ifoldMapOf' l = 'foldMapOf' l '.' 'Indexed' -- @ -- -- @ -- 'foldMapOf' :: 'Getter' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Lens'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Iso'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Prism'' s a -> (a -> r) -> s -> r -- @ -- -- @ -- '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) {-# INLINE foldMapOf #-} -- | @ -- 'Data.Foldable.fold' = 'foldOf' 'folded' -- @ -- -- @ -- 'foldOf' ≡ 'view' -- @ -- -- @ -- 'foldOf' :: 'Getter' s m -> s -> m -- 'foldOf' :: 'Monoid' m => 'Fold' s m -> s -> m -- 'foldOf' :: 'Lens'' s m -> s -> m -- 'foldOf' :: 'Iso'' s m -> s -> m -- 'foldOf' :: 'Monoid' m => 'Traversal'' s m -> s -> m -- 'foldOf' :: 'Monoid' m => 'Prism'' s m -> s -> m -- @ foldOf :: Getting a s a -> s -> a foldOf l = runAccessor #. l Accessor {-# INLINE foldOf #-} -- | Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. -- -- @ -- 'Data.Foldable.foldr' ≡ 'foldrOf' 'folded' -- @ -- -- @ -- 'foldrOf' :: 'Getter' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Fold' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Lens'' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Iso'' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Prism'' s a -> (a -> r -> r) -> r -> s -> r -- @ -- -- @ -- 'ifoldrOf' l ≡ 'foldrOf' l '.' 'Indexed' -- @ -- -- @ -- 'foldrOf' :: 'Getting' ('Endo' r) s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf :: Profunctor p => Accessing p (Endo r) s a -> p a (r -> r) -> r -> s -> r foldrOf l f z = flip appEndo z `rmap` foldMapOf l (Endo #. f) {-# INLINE foldrOf #-} -- | Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. -- -- @ -- 'Data.Foldable.foldl' ≡ 'foldlOf' 'folded' -- @ -- -- @ -- 'foldlOf' :: 'Getter' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Fold' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Lens'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Iso'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Prism'' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf :: Getting (Dual (Endo r)) s a -> (r -> a -> r) -> r -> s -> r foldlOf l f z = (flip appEndo z .# getDual) `rmap` foldMapOf l (Dual #. Endo #. flip f) {-# INLINE foldlOf #-} -- | Extract a list of the targets of a 'Fold'. See also ('^..'). -- -- @ -- 'Data.Foldable.toList' ≡ 'toListOf' 'folded' -- ('^..') ≡ 'flip' 'toListOf' -- @ -- >>> toListOf both ("hello","world") -- ["hello","world"] -- -- @ -- 'toListOf' :: 'Getter' s a -> s -> [a] -- 'toListOf' :: 'Fold' s a -> s -> [a] -- 'toListOf' :: 'Lens'' s a -> s -> [a] -- 'toListOf' :: 'Iso'' s a -> s -> [a] -- 'toListOf' :: 'Traversal'' s a -> s -> [a] -- 'toListOf' :: 'Prism'' s a -> s -> [a] -- @ toListOf :: Getting (Endo [a]) s a -> s -> [a] toListOf l = foldrOf l (:) [] {-# INLINE toListOf #-} -- | A convenient infix (flipped) version of 'toListOf'. -- -- >>> [[1,2],[3]]^..traverse.traverse -- [1,2,3] -- -- >>> (1,2)^..both -- [1,2] -- -- @ -- 'Data.Foldable.toList' xs ≡ xs '^..' 'folded' -- ('^..') ≡ 'flip' 'toListOf' -- @ -- -- @ -- ('^..') :: s -> 'Getter' s a -> [a] -- ('^..') :: s -> 'Fold' s a -> [a] -- ('^..') :: s -> 'Lens'' s a -> [a] -- ('^..') :: s -> 'Iso'' s a -> [a] -- ('^..') :: s -> 'Traversal'' s a -> [a] -- ('^..') :: s -> 'Prism'' s a -> [a] -- @ (^..) :: s -> Getting (Endo [a]) s a -> [a] s ^.. l = toListOf l s {-# INLINE (^..) #-} -- | Returns 'True' if every target of a 'Fold' is 'True'. -- -- >>> andOf both (True,False) -- False -- >>> andOf both (True,True) -- True -- -- @ -- 'Data.Foldable.and' ≡ 'andOf' 'folded' -- @ -- -- @ -- 'andOf' :: 'Getter' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Fold' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Lens'' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Iso'' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Traversal'' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Prism'' s 'Bool' -> s -> 'Bool' -- @ andOf :: Getting All s Bool -> s -> Bool andOf l = getAll #. foldMapOf l All {-# INLINE andOf #-} -- | Returns 'True' if any target of a 'Fold' is 'True'. -- -- >>> orOf both (True,False) -- True -- >>> orOf both (False,False) -- False -- -- @ -- 'Data.Foldable.or' ≡ 'orOf' 'folded' -- @ -- -- @ -- 'orOf' :: 'Getter' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Fold' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Lens'' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Iso'' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Traversal'' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Prism'' s 'Bool' -> s -> 'Bool' -- @ orOf :: Getting Any s Bool -> s -> Bool orOf l = getAny #. foldMapOf l Any {-# INLINE orOf #-} -- | Returns 'True' if any target of a 'Fold' satisfies a predicate. -- -- >>> anyOf both (=='x') ('x','y') -- True -- >>> import Data.Data.Lens -- >>> anyOf biplate (== "world") (((),2::Int),"hello",("world",11)) -- True -- -- @ -- 'Data.Foldable.any' ≡ 'anyOf' 'folded' -- @ -- -- @ -- 'ianyOf' l ≡ 'allOf' l '.' 'Indexed' -- @ -- -- @ -- 'anyOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ anyOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool anyOf l f = getAny #. foldMapOf l (Any #. f) {-# INLINE anyOf #-} -- | Returns 'True' if every target of a 'Fold' satisfies a predicate. -- -- >>> allOf both (>=3) (4,5) -- True -- >>> allOf folded (>=2) [1..10] -- False -- -- @ -- 'Data.Foldable.all' ≡ 'allOf' 'folded' -- @ -- -- @ -- 'iallOf' l = 'allOf' l '.' 'Indexed' -- @ -- -- @ -- 'allOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ allOf :: Profunctor p => Accessing p All s a -> p a Bool -> s -> Bool allOf l f = getAll #. foldMapOf l (All #. f) {-# INLINE allOf #-} -- | Calculate the 'Product' of every number targeted by a 'Fold'. -- -- >>> productOf both (4,5) -- 20 -- >>> productOf folded [1,2,3,4,5] -- 120 -- -- @ -- 'Data.Foldable.product' ≡ 'productOf' 'folded' -- @ -- This operation may be more strict than you would expect. If you -- want a lazier version use @'ala' 'Sum' '.' 'foldMapOf'@ -- -- @ -- 'productOf' :: 'Num' a => 'Getter' s a -> s -> a -- 'productOf' :: 'Num' a => 'Fold' s a -> s -> a -- 'productOf' :: 'Num' a => 'Lens'' s a -> s -> a -- 'productOf' :: 'Num' a => 'Iso'' s a -> s -> a -- 'productOf' :: 'Num' a => 'Traversal'' s a -> s -> a -- 'productOf' :: 'Num' a => 'Prism'' s a -> s -> a -- @ productOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a productOf l = foldlOf' l (*) 1 {-# INLINE productOf #-} -- | Calculate the 'Sum' of every number targeted by a 'Fold'. -- -- >>> sumOf both (5,6) -- 11 -- >>> sumOf folded [1,2,3,4] -- 10 -- >>> sumOf (folded.both) [(1,2),(3,4)] -- 10 -- >>> import Data.Data.Lens -- >>> sumOf biplate [(1::Int,[]),(2,[(3::Int,4::Int)])] :: Int -- 10 -- -- @ -- 'Data.Foldable.sum' ≡ 'sumOf' 'folded' -- @ -- -- This operation may be more strict than you would expect. If you -- want a lazier version use @'ala' 'Sum' '.' 'foldMapOf'@ -- -- @ -- 'sumOf' '_1' :: 'Num' a => (a, b) -> a -- 'sumOf' ('folded' '.' 'Control.Lens.Tuple._1') :: ('Foldable' f, 'Num' a) => f (a, b) -> a -- @ -- -- @ -- 'sumOf' :: 'Num' a => 'Getter' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Fold' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Lens'' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Iso'' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Traversal'' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Prism'' s a -> s -> a -- @ sumOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a sumOf l = foldlOf' l (+) 0 {-# INLINE sumOf #-} -- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor')-based answer, -- but unlike 'Control.Lens.Traversal.traverseOf' do not construct a new structure. 'traverseOf_' generalizes -- 'Data.Foldable.traverse_' to work over any 'Fold'. -- -- When passed a 'Getter', 'traverseOf_' can work over any 'Functor', but when passed a 'Fold', 'traverseOf_' requires -- an 'Applicative'. -- -- >>> traverseOf_ both putStrLn ("hello","world") -- hello -- world -- -- @ -- 'Data.Foldable.traverse_' ≡ 'traverseOf_' 'folded' -- @ -- -- @ -- 'traverseOf_' '_2' :: 'Functor' f => (c -> f r) -> (d, c) -> f () -- 'traverseOf_' 'Control.Lens.Prism._Left' :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f () -- @ -- -- @ -- 'itraverseOf_' l ≡ 'traverseOf_' l '.' 'Indexed' -- @ -- -- The rather specific signature of 'traverseOf_' allows it to be used as if the signature was any of: -- -- @ -- 'traverseOf_' :: 'Functor' f => 'Getter' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Fold' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Functor' f => 'Lens'' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Functor' f => 'Iso'' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Traversal'' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Prism'' s a -> (a -> f r) -> s -> f () -- @ traverseOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> p a (f r) -> s -> f () traverseOf_ l f = void . getTraversed #. foldMapOf l (Traversed #. f) {-# INLINE traverseOf_ #-} -- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor')-based answer, -- but unlike 'Control.Lens.Traversal.forOf' do not construct a new structure. 'forOf_' generalizes -- 'Data.Foldable.for_' to work over any 'Fold'. -- -- When passed a 'Getter', 'forOf_' can work over any 'Functor', but when passed a 'Fold', 'forOf_' requires -- an 'Applicative'. -- -- @ -- 'for_' ≡ 'forOf_' 'folded' -- @ -- -- >>> forOf_ both ("hello","world") putStrLn -- hello -- world -- -- The rather specific signature of 'forOf_' allows it to be used as if the signature was any of: -- -- @ -- 'iforOf_' l s ≡ 'forOf_' l s '.' 'Indexed' -- @ -- -- @ -- 'forOf_' :: 'Functor' f => 'Getter' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Fold' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Functor' f => 'Lens'' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Functor' f => 'Iso'' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Traversal'' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Prism'' s a -> s -> (a -> f r) -> f () -- @ forOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> s -> p a (f r) -> f () forOf_ = flip . traverseOf_ {-# INLINE forOf_ #-} -- | Evaluate each action in observed by a 'Fold' on a structure from left to right, ignoring the results. -- -- @ -- 'sequenceA_' ≡ 'sequenceAOf_' 'folded' -- @ -- -- >>> sequenceAOf_ both (putStrLn "hello",putStrLn "world") -- hello -- world -- -- @ -- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Functor' f => 'Lens'' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Functor' f => 'Iso'' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Applicative' f => 'Traversal'' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Applicative' f => 'Prism'' s (f a) -> s -> f () -- @ sequenceAOf_ :: Functor f => Getting (Traversed a f) s (f a) -> s -> f () sequenceAOf_ l = void . getTraversed #. foldMapOf l Traversed {-# INLINE sequenceAOf_ #-} -- | Map each target of a 'Fold' on a structure to a monadic action, evaluate these actions from left to right, and ignore the results. -- -- >>> mapMOf_ both putStrLn ("hello","world") -- hello -- world -- -- @ -- 'Data.Foldable.mapM_' ≡ 'mapMOf_' 'folded' -- @ -- -- @ -- 'mapMOf_' :: 'Monad' m => 'Getter' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Fold' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Lens'' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Iso'' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Traversal'' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Prism'' s a -> (a -> m r) -> s -> m () -- @ mapMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> p a (m r) -> s -> m () mapMOf_ l f = liftM skip . getSequenced #. foldMapOf l (Sequenced #. f) {-# INLINE mapMOf_ #-} -- | 'forMOf_' is 'mapMOf_' with two of its arguments flipped. -- -- >>> forMOf_ both ("hello","world") putStrLn -- hello -- world -- -- @ -- 'Data.Foldable.forM_' ≡ 'forMOf_' 'folded' -- @ -- -- @ -- 'forMOf_' :: 'Monad' m => 'Getter' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Fold' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Lens'' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Iso'' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Traversal'' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Prism'' s a -> s -> (a -> m r) -> m () -- @ forMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> s -> p a (m r) -> m () forMOf_ = flip . mapMOf_ {-# INLINE forMOf_ #-} -- | Evaluate each monadic action referenced by a 'Fold' on the structure from left to right, and ignore the results. -- -- >>> sequenceOf_ both (putStrLn "hello",putStrLn "world") -- hello -- world -- -- @ -- 'Data.Foldable.sequence_' ≡ 'sequenceOf_' 'folded' -- @ -- -- @ -- 'sequenceOf_' :: 'Monad' m => 'Getter' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Fold' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Lens'' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Iso'' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Traversal'' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Prism'' s (m a) -> s -> m () -- @ sequenceOf_ :: Monad m => Getting (Sequenced a m) s (m a) -> s -> m () sequenceOf_ l = liftM skip . getSequenced #. foldMapOf l Sequenced {-# INLINE sequenceOf_ #-} -- | The sum of a collection of actions, generalizing 'concatOf'. -- -- >>> asumOf both ("hello","world") -- "helloworld" -- -- >>> asumOf each (Nothing, Just "hello", Nothing) -- Just "hello" -- -- @ -- 'asum' ≡ 'asumOf' 'folded' -- @ -- -- @ -- 'asumOf' :: 'Alternative' f => 'Getter' s (f a) -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Fold' s (f a) -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Lens'' s (f a) -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Iso'' s (f a) -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Traversal'' s (f a) -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Prism'' s (f a) -> s -> f a -- @ asumOf :: Alternative f => Getting (Endo (f a)) s (f a) -> s -> f a asumOf l = foldrOf l (<|>) Applicative.empty {-# INLINE asumOf #-} -- | The sum of a collection of actions, generalizing 'concatOf'. -- -- >>> msumOf both ("hello","world") -- "helloworld" -- -- >>> msumOf each (Nothing, Just "hello", Nothing) -- Just "hello" -- -- @ -- 'msum' ≡ 'msumOf' 'folded' -- @ -- -- @ -- 'msumOf' :: 'MonadPlus' m => 'Getter' s (m a) -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Fold' s (m a) -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Lens'' s (m a) -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Iso'' s (m a) -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Traversal'' s (m a) -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Prism'' s (m a) -> s -> m a -- @ msumOf :: MonadPlus m => Getting (Endo (m a)) s (m a) -> s -> m a msumOf l = foldrOf l mplus mzero {-# INLINE msumOf #-} -- | Does the element occur anywhere within a given 'Fold' of the structure? -- -- >>> elemOf both "hello" ("hello","world") -- True -- -- @ -- 'elem' ≡ 'elemOf' 'folded' -- @ -- -- @ -- 'elemOf' :: 'Eq' a => 'Getter' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Fold' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Lens'' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Iso'' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Traversal'' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Prism'' s a -> a -> s -> 'Bool' -- @ elemOf :: Eq a => Getting Any s a -> a -> s -> Bool elemOf l = anyOf l . (==) {-# INLINE elemOf #-} -- | Does the element not occur anywhere within a given 'Fold' of the structure? -- -- >>> notElemOf each 'd' ('a','b','c') -- True -- -- >>> notElemOf each 'a' ('a','b','c') -- False -- -- @ -- 'notElem' ≡ 'notElemOf' 'folded' -- @ -- -- @ -- 'notElemOf' :: 'Eq' a => 'Getter' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Fold' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Iso'' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Lens'' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Traversal'' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Prism'' s a -> a -> s -> 'Bool' -- @ notElemOf :: Eq a => Getting All s a -> a -> s -> Bool notElemOf l = allOf l . (/=) {-# INLINE notElemOf #-} -- | Map a function over all the targets of a 'Fold' of a container and concatenate the resulting lists. -- -- >>> concatMapOf both (\x -> [x, x + 1]) (1,3) -- [1,2,3,4] -- -- @ -- 'concatMap' ≡ 'concatMapOf' 'folded' -- @ -- -- @ -- 'concatMapOf' :: 'Getter' s a -> (a -> [r]) -> s -> [r] -- 'concatMapOf' :: 'Fold' s a -> (a -> [r]) -> s -> [r] -- 'concatMapOf' :: 'Lens'' s a -> (a -> [r]) -> s -> [r] -- 'concatMapOf' :: 'Iso'' s a -> (a -> [r]) -> s -> [r] -- '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) {-# INLINE concatMapOf #-} -- | Concatenate all of the lists targeted by a 'Fold' into a longer list. -- -- >>> concatOf both ("pan","ama") -- "panama" -- -- @ -- 'concat' ≡ 'concatOf' 'folded' -- 'concatOf' ≡ 'view' -- @ -- -- @ -- 'concatOf' :: 'Getter' s [r] -> s -> [r] -- 'concatOf' :: 'Fold' s [r] -> s -> [r] -- 'concatOf' :: 'Iso'' s [r] -> s -> [r] -- 'concatOf' :: 'Lens'' s [r] -> s -> [r] -- 'concatOf' :: 'Traversal'' s [r] -> s -> [r] -- @ concatOf :: Getting [r] s [r] -> s -> [r] concatOf l = runAccessor #. l Accessor {-# INLINE concatOf #-} -- | Calculate the number of targets there are for a 'Fold' in a given container. -- -- /Note:/ This can be rather inefficient for large containers and just like 'length', -- this will not terminate for infinite folds. -- -- @ -- 'length' ≡ 'lengthOf' 'folded' -- @ -- -- >>> lengthOf _1 ("hello",()) -- 1 -- -- >>> lengthOf traverse [1..10] -- 10 -- -- >>> lengthOf (traverse.traverse) [[1,2],[3,4],[5,6]] -- 6 -- -- @ -- 'lengthOf' ('folded' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a) -> 'Int' -- @ -- -- @ -- 'lengthOf' :: 'Getter' s a -> s -> 'Int' -- 'lengthOf' :: 'Fold' s a -> s -> 'Int' -- 'lengthOf' :: 'Lens'' s a -> s -> 'Int' -- 'lengthOf' :: 'Iso'' s a -> s -> 'Int' -- 'lengthOf' :: 'Traversal'' s a -> s -> 'Int' -- @ lengthOf :: Getting (Endo (Endo Int)) s a -> s -> Int lengthOf l = foldlOf' l (\a _ -> a + 1) 0 {-# INLINE lengthOf #-} -- | Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. -- -- When using a 'Traversal' as a partial 'Lens', or a 'Fold' as a partial 'Getter' this can be a convenient -- way to extract the optional value. -- -- Note: if you get stack overflows due to this, you may want to use 'firstOf' instead, which can deal -- more gracefully with heavily left-biased trees. -- -- >>> Left 4 ^?_Left -- Just 4 -- -- >>> Right 4 ^?_Left -- Nothing -- -- >>> "world" ^? ix 3 -- Just 'l' -- -- >>> "world" ^? ix 20 -- Nothing -- -- @ -- ('^?') ≡ 'flip' 'preview' -- @ -- -- @ -- ('^?') :: s -> 'Getter' s a -> 'Maybe' a -- ('^?') :: s -> 'Fold' s a -> 'Maybe' a -- ('^?') :: s -> 'Lens'' s a -> 'Maybe' a -- ('^?') :: s -> 'Iso'' s a -> 'Maybe' a -- ('^?') :: s -> 'Traversal'' s a -> 'Maybe' a -- @ (^?) :: s -> Getting (First a) s a -> Maybe a s ^? l = getFirst (foldMapOf l (First #. Just) s) {-# INLINE (^?) #-} -- | Perform an *UNSAFE* 'head' of a 'Fold' or 'Traversal' assuming that it is there. -- -- >>> Left 4 ^?! _Left -- 4 -- -- >>> "world" ^?! ix 3 -- 'l' -- -- @ -- ('^?!') :: s -> 'Getter' s a -> a -- ('^?!') :: s -> 'Fold' s a -> a -- ('^?!') :: s -> 'Lens'' s a -> a -- ('^?!') :: s -> 'Iso'' s a -> a -- ('^?!') :: s -> 'Traversal'' s a -> a -- @ (^?!) :: s -> Getting (Endo a) s a -> a s ^?! l = foldrOf l const (error "(^?!): empty Fold") s {-# INLINE (^?!) #-} -- | Retrieve the 'First' entry of a 'Fold' or 'Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. -- -- The answer is computed in a manner that leaks space less than @'ala' 'First' '.' 'foldMapOf'@ -- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse -- constant factors. -- -- >>> firstOf traverse [1..10] -- Just 1 -- -- >>> firstOf both (1,2) -- Just 1 -- -- >>> firstOf ignored () -- Nothing -- -- @ -- 'firstOf' :: 'Getter' s a -> s -> 'Maybe' a -- 'firstOf' :: 'Fold' s a -> s -> 'Maybe' a -- 'firstOf' :: 'Lens'' s a -> s -> 'Maybe' a -- 'firstOf' :: 'Iso'' s a -> s -> 'Maybe' a -- 'firstOf' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ firstOf :: Getting (Leftmost a) s a -> s -> Maybe a firstOf l = getLeftmost . foldMapOf l LLeaf {-# INLINE firstOf #-} -- | Retrieve the 'Last' entry of a 'Fold' or 'Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. -- -- The answer is computed in a manner that leaks space less than @'ala' 'Last' '.' 'foldMapOf'@ -- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse -- constant factors. -- -- >>> lastOf traverse [1..10] -- Just 10 -- -- >>> lastOf both (1,2) -- Just 2 -- -- >>> lastOf ignored () -- Nothing -- -- @ -- 'lastOf' :: 'Getter' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Fold' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Lens'' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Iso'' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ lastOf :: Getting (Rightmost a) s a -> s -> Maybe a lastOf l = getRightmost . foldMapOf l RLeaf {-# INLINE lastOf #-} -- | Returns 'True' if this 'Fold' or 'Traversal' has no targets in the given container. -- -- Note: 'nullOf' on a valid 'Iso', 'Lens' or 'Getter' should always return 'False'. -- -- @ -- 'null' ≡ 'nullOf' 'folded' -- @ -- -- This may be rather inefficient compared to the 'null' check of many containers. -- -- >>> nullOf _1 (1,2) -- False -- -- >>> nullOf ignored () -- True -- -- >>> nullOf traverse [] -- True -- -- >>> nullOf (element 20) [1..10] -- True -- -- @ -- 'nullOf' ('folded' '.' '_1' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a, b) -> 'Bool' -- @ -- -- @ -- 'nullOf' :: 'Getter' s a -> s -> 'Bool' -- 'nullOf' :: 'Fold' s a -> s -> 'Bool' -- 'nullOf' :: 'Iso'' s a -> s -> 'Bool' -- 'nullOf' :: 'Lens'' s a -> s -> 'Bool' -- 'nullOf' :: 'Traversal'' s a -> s -> 'Bool' -- @ nullOf :: Getting All s a -> s -> Bool nullOf = hasn't {-# INLINE nullOf #-} -- | Returns 'True' if this 'Fold' or 'Traversal' has any targets in the given container. -- -- A more \"conversational\" alias for this combinator is 'has'. -- -- Note: 'notNullOf' on a valid 'Iso', 'Lens' or 'Getter' should always return 'True'. -- -- @ -- 'null' ≡ 'notNullOf' 'folded' -- @ -- -- This may be rather inefficient compared to the @'not' '.' 'null'@ check of many containers. -- -- >>> notNullOf _1 (1,2) -- True -- -- >>> notNullOf traverse [1..10] -- True -- -- >>> notNullOf folded [] -- False -- -- >>> notNullOf (element 20) [1..10] -- False -- -- @ -- 'notNullOf' ('folded' '.' '_1' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a, b) -> 'Bool' -- @ -- -- @ -- 'notNullOf' :: 'Getter' s a -> s -> 'Bool' -- 'notNullOf' :: 'Fold' s a -> s -> 'Bool' -- 'notNullOf' :: 'Iso'' s a -> s -> 'Bool' -- 'notNullOf' :: 'Lens'' s a -> s -> 'Bool' -- 'notNullOf' :: 'Traversal'' s a -> s -> 'Bool' -- @ notNullOf :: Getting Any s a -> s -> Bool notNullOf = has {-# INLINE notNullOf #-} -- | Obtain the maximum element (if any) targeted by a 'Fold' or 'Traversal' safely. -- -- Note: 'maximumOf' on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. -- -- >>> maximumOf traverse [1..10] -- Just 10 -- -- >>> maximumOf traverse [] -- Nothing -- -- >>> maximumOf (folded.filtered even) [1,4,3,6,7,9,2] -- Just 6 -- -- @ -- 'maximum' ≡ 'fromMaybe' ('error' \"empty\") '.' 'maximumOf' 'folded' -- @ -- -- In the interest of efficiency, This operation has semantics more strict than strictly necessary. -- @'rmap' 'getMax' ('foldMapOf' l 'Max')@ has lazier semantics but could leak memory. -- -- @ -- 'maximumOf' :: 'Ord' a => 'Getter' s a -> s -> 'Maybe' a -- 'maximumOf' :: 'Ord' a => 'Fold' s a -> s -> 'Maybe' a -- 'maximumOf' :: 'Ord' a => 'Iso'' s a -> s -> 'Maybe' a -- 'maximumOf' :: 'Ord' a => 'Lens'' s a -> s -> 'Maybe' a -- 'maximumOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Maybe' a -- @ maximumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a maximumOf l = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! max x y {-# INLINE maximumOf #-} -- | Obtain the minimum element (if any) targeted by a 'Fold' or 'Traversal' safely. -- -- Note: 'minimumOf' on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. -- -- >>> minimumOf traverse [1..10] -- Just 1 -- -- >>> minimumOf traverse [] -- Nothing -- -- >>> minimumOf (folded.filtered even) [1,4,3,6,7,9,2] -- Just 2 -- -- @ -- 'minimum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumOf' 'folded' -- @ -- -- In the interest of efficiency, This operation has semantics more strict than strictly necessary. -- @'rmap' 'getMin' ('foldMapOf' l 'Min')@ has lazier semantics but could leak memory. -- -- -- @ -- 'minimumOf' :: 'Ord' a => 'Getter' s a -> s -> 'Maybe' a -- 'minimumOf' :: 'Ord' a => 'Fold' s a -> s -> 'Maybe' a -- 'minimumOf' :: 'Ord' a => 'Iso'' s a -> s -> 'Maybe' a -- 'minimumOf' :: 'Ord' a => 'Lens'' s a -> s -> 'Maybe' a -- 'minimumOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Maybe' a -- @ minimumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a minimumOf l = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! min x y {-# INLINE minimumOf #-} -- | Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', -- or 'Getter' according to a user supplied 'Ordering'. -- -- >>> maximumByOf traverse (compare `on` length) ["mustard","relish","ham"] -- Just "mustard" -- -- In the interest of efficiency, This operation has semantics more strict than strictly necessary. -- -- @ -- 'Data.Foldable.maximumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'maximumByOf' 'folded' cmp -- @ -- -- @ -- 'maximumByOf' :: 'Getter' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'maximumByOf' :: 'Fold' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'maximumByOf' :: 'Iso'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'maximumByOf' :: 'Lens'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'maximumByOf' :: 'Traversal'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- @ maximumByOf :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> Ordering) -> s -> Maybe a maximumByOf l cmp = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! if cmp x y == GT then x else y {-# INLINE maximumByOf #-} -- | Obtain the minimum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso' -- or 'Getter' according to a user supplied 'Ordering'. -- -- In the interest of efficiency, This operation has semantics more strict than strictly necessary. -- -- >>> minimumByOf traverse (compare `on` length) ["mustard","relish","ham"] -- Just "ham" -- -- @ -- 'minimumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumByOf' 'folded' cmp -- @ -- -- @ -- 'minimumByOf' :: 'Getter' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'minimumByOf' :: 'Fold' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'minimumByOf' :: 'Iso'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'minimumByOf' :: 'Lens'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'minimumByOf' :: 'Traversal'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- @ minimumByOf :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> Ordering) -> s -> Maybe a minimumByOf l cmp = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! if cmp x y == GT then y else x {-# INLINE minimumByOf #-} -- | The 'findOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'), -- a predicate and a structure and returns the leftmost element of the structure -- matching the predicate, or 'Nothing' if there is no such element. -- -- >>> findOf each even (1,3,4,6) -- Just 4 -- -- >>> findOf folded even [1,3,5,7] -- Nothing -- -- @ -- 'findOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- @ -- -- @ -- 'Data.Foldable.find' ≡ 'findOf' 'folded' -- 'ifindOf' l ≡ 'findOf' l '.' 'Indexed' -- @ -- -- A simpler version that didn't permit indexing, would be: -- -- @ -- 'findOf' :: 'Getting' ('Endo' ('Maybe' a)) s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' l p = 'foldrOf' l (\a y -> if p a then 'Just' a else y) 'Nothing' -- @ findOf :: Conjoined p => Accessing p (Endo (Maybe a)) s a -> p a Bool -> s -> Maybe a findOf l p = foldrOf l (cotabulate $ \wa y -> if corep p wa then Just (extract wa) else y) Nothing {-# INLINE findOf #-} -- | 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. -- -- >>> foldr1Of each (+) (1,2,3,4) -- 10 -- -- @ -- 'foldr1Of' l f ≡ 'Prelude.foldr1' f '.' 'toListOf' l -- 'Data.Foldable.foldr1' ≡ 'foldr1Of' 'folded' -- @ -- -- @ -- 'foldr1Of' :: 'Getter' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Fold' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Iso'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of :: Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") (foldrOf l mf Nothing xs) where mf x my = Just $ case my of Nothing -> x Just y -> f x y {-# INLINE foldr1Of #-} -- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and structures such -- that the 'Lens' views at least one element of the structure. -- -- >>> foldl1Of each (+) (1,2,3,4) -- 10 -- -- @ -- 'foldl1Of' l f ≡ 'Prelude.foldl1' f '.' 'toListOf' l -- 'Data.Foldable.foldl1' ≡ 'foldl1Of' 'folded' -- @ -- -- @ -- 'foldl1Of' :: 'Getter' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Fold' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Iso'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of :: Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where mf mx y = Just $ case mx of Nothing -> y Just x -> f x y {-# INLINE foldl1Of #-} -- | Strictly fold right over the elements of a structure. -- -- @ -- 'Data.Foldable.foldr'' ≡ 'foldrOf'' 'folded' -- @ -- -- @ -- 'foldrOf'' :: 'Getter' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf'' :: 'Fold' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf'' :: 'Iso'' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf'' :: 'Lens'' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldrOf' #-} -- | Fold over the elements of a structure, associating to the left, but strictly. -- -- @ -- 'Data.Foldable.foldl'' ≡ 'foldlOf'' 'folded' -- @ -- -- @ -- 'foldlOf'' :: 'Getter' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf'' :: 'Fold' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf'' :: 'Iso'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf'' :: 'Lens'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0 where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} -- | A variant of 'foldrOf'' that has no base case and thus may only be applied -- to folds and structures such that the fold views at least one element of the -- structure. -- -- @ -- 'foldr1Of' l f ≡ 'Prelude.foldr1' f '.' 'toListOf' l -- @ -- -- @ -- 'foldr1Of'' :: 'Getter' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Fold' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Iso'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of' :: Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where mf x Nothing = Just $! x mf x (Just y) = Just $! f x y {-# INLINE foldr1Of' #-} -- | A variant of 'foldlOf'' that has no base case and thus may only be applied -- to folds and structures such that the fold views at least one element of -- the structure. -- -- @ -- 'foldl1Of'' l f ≡ 'Data.List.foldl1'' f '.' 'toListOf' l -- @ -- -- @ -- 'foldl1Of'' :: 'Getter' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Fold' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Iso'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of' :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where mf Nothing y = Just $! y mf (Just x) y = Just $! f x y {-# INLINE foldl1Of' #-} -- | Monadic fold over the elements of a structure, associating to the right, -- i.e. from right to left. -- -- @ -- 'Data.Foldable.foldrM' ≡ 'foldrMOf' 'folded' -- @ -- -- @ -- 'foldrMOf' :: 'Monad' m => 'Getter' s a -> (a -> r -> m r) -> r -> s -> m r -- 'foldrMOf' :: 'Monad' m => 'Fold' s a -> (a -> r -> m r) -> r -> s -> m r -- 'foldrMOf' :: 'Monad' m => 'Iso'' s a -> (a -> r -> m r) -> r -> s -> m r -- 'foldrMOf' :: 'Monad' m => 'Lens'' s a -> (a -> r -> m r) -> r -> s -> m r -- 'foldrMOf' :: 'Monad' m => 'Traversal'' s a -> (a -> r -> m r) -> r -> s -> m r -- @ foldrMOf :: Monad m => Getting (Dual (Endo (r -> m r))) s a -> (a -> r -> m r) -> r -> s -> m r foldrMOf l f z0 xs = foldlOf l f' return xs z0 where f' k x z = f x z >>= k {-# INLINE foldrMOf #-} -- | Monadic fold over the elements of a structure, associating to the left, -- i.e. from left to right. -- -- @ -- 'Data.Foldable.foldlM' ≡ 'foldlMOf' 'folded' -- @ -- -- @ -- 'foldlMOf' :: 'Monad' m => 'Getter' s a -> (r -> a -> m r) -> r -> s -> m r -- 'foldlMOf' :: 'Monad' m => 'Fold' s a -> (r -> a -> m r) -> r -> s -> m r -- 'foldlMOf' :: 'Monad' m => 'Iso'' s a -> (r -> a -> m r) -> r -> s -> m r -- 'foldlMOf' :: 'Monad' m => 'Lens'' s a -> (r -> a -> m r) -> r -> s -> m r -- 'foldlMOf' :: 'Monad' m => 'Traversal'' s a -> (r -> a -> m r) -> r -> s -> m r -- @ foldlMOf :: Monad m => Getting (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r foldlMOf l f z0 xs = foldrOf l f' return xs z0 where f' x k z = f z x >>= k {-# INLINE foldlMOf #-} -- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries. -- -- >>> has (element 0) [] -- False -- -- >>> has _Left (Left 12) -- True -- -- >>> has _Right (Left 12) -- False -- -- This will always return 'True' for a 'Lens' or 'Getter'. -- -- >>> has _1 ("hello","world") -- True -- -- @ -- 'has' :: 'Getter' s a -> s -> 'Bool' -- 'has' :: 'Fold' s a -> s -> 'Bool' -- 'has' :: 'Iso'' s a -> s -> 'Bool' -- 'has' :: 'Lens'' s a -> s -> 'Bool' -- 'has' :: 'Traversal'' s a -> s -> 'Bool' -- @ has :: Getting Any s a -> s -> Bool has l = getAny #. foldMapOf l (\_ -> Any True) {-# INLINE has #-} -- | Check to see if this 'Fold' or 'Traversal' has no matches. -- -- >>> hasn't _Left (Right 12) -- True -- -- >>> hasn't _Left (Left 12) -- False hasn't :: Getting All s a -> s -> Bool hasn't l = getAll #. foldMapOf l (\_ -> All False) {-# INLINE hasn't #-} ------------------------------------------------------------------------------ -- Pre ------------------------------------------------------------------------------ -- | This converts a 'Fold' to a 'IndexPreservingGetter' that returns the first element, if it -- exists, as a 'Maybe'. -- -- @ -- 'pre' :: 'Getter' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Fold' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Simple' 'Traversal' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Simple' 'Lens' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Simple' 'Iso' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- '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 {-# INLINE pre #-} -- | This converts an 'IndexedFold' to an 'IndexPreservingGetter' that returns the first index -- and element, if they exist, as a 'Maybe'. -- -- @ -- 'ipre' :: 'IndexedGetter' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- 'ipre' :: 'IndexedFold' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- 'ipre' :: 'Simple' ('IndexedTraversal' i) s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- '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 {-# INLINE ipre #-} ------------------------------------------------------------------------------ -- Preview ------------------------------------------------------------------------------ -- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result -- from a 'Getter' or 'Lens'). See also ('^?'). -- -- @ -- 'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded' -- @ -- -- This is usually applied in the 'Control.Monad.Reader.Reader' -- 'Control.Monad.Monad' @(->) s@. -- -- @ -- 'preview' = 'view' '.' 'pre' -- @ -- -- @ -- 'preview' :: 'Getter' s a -> s -> 'Maybe' a -- 'preview' :: 'Fold' s a -> s -> 'Maybe' a -- 'preview' :: 'Lens'' s a -> s -> 'Maybe' a -- 'preview' :: 'Iso'' s a -> s -> 'Maybe' a -- 'preview' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ -- -- However, it may be useful to think of its full generality when working with -- a 'Control.Monad.Monad' transformer stack: -- -- @ -- 'preview' :: 'MonadReader' s m => 'Getter' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Fold' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Lens'' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Iso'' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Traversal'' s a -> m ('Maybe' a) -- @ preview :: MonadReader s m => Getting (First a) s a -> m (Maybe a) preview l = asks (getFirst #. foldMapOf l (First #. Just)) {-# INLINE preview #-} -- | Retrieve the first index and value targeted by a 'Fold' or 'Traversal' (or 'Just' the result -- from a 'Getter' or 'Lens'). See also ('^@?'). -- -- @ -- 'ipreview' = 'view' '.' 'ipre' -- @ -- -- This is usually applied in the 'Control.Monad.Reader.Reader' -- 'Control.Monad.Monad' @(->) s@. -- -- @ -- 'ipreview' :: 'IndexedGetter' i s a -> s -> 'Maybe' (i, a) -- 'ipreview' :: 'IndexedFold' i s a -> s -> 'Maybe' (i, a) -- 'ipreview' :: 'IndexedLens'' i s a -> s -> 'Maybe' (i, a) -- 'ipreview' :: 'IndexedTraversal'' i s a -> s -> 'Maybe' (i, a) -- @ -- -- However, it may be useful to think of its full generality when working with -- a 'Control.Monad.Monad' transformer stack: -- -- @ -- 'ipreview' :: 'MonadReader' s m => 'IndexedGetter' s a -> m ('Maybe' (i, a)) -- 'ipreview' :: 'MonadReader' s m => 'IndexedFold' s a -> m ('Maybe' (i, a)) -- 'ipreview' :: 'MonadReader' s m => 'IndexedLens'' s a -> m ('Maybe' (i, a)) -- 'ipreview' :: 'MonadReader' s m => 'IndexedTraversal'' s a -> m ('Maybe' (i, a)) -- @ ipreview :: MonadReader s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a)) ipreview l = asks (getFirst #. ifoldMapOf l (\i a -> First (Just (i, a)))) {-# INLINE ipreview #-} -- | Retrieve a function of the first value targeted by a 'Fold' or -- 'Traversal' (or 'Just' the result from a 'Getter' or 'Lens'). -- -- This is usually applied in the 'Control.Monad.Reader.Reader' -- 'Control.Monad.Monad' @(->) s@. -- @ -- 'previews' = 'views' '.' 'pre' -- @ -- -- @ -- 'previews' :: 'Getter' s a -> (a -> r) -> s -> 'Maybe' r -- 'previews' :: 'Fold' s a -> (a -> r) -> s -> 'Maybe' r -- 'previews' :: 'Lens'' s a -> (a -> r) -> s -> 'Maybe' r -- 'previews' :: 'Iso'' s a -> (a -> r) -> s -> 'Maybe' r -- 'previews' :: 'Traversal'' s a -> (a -> r) -> s -> 'Maybe' r -- @ -- -- However, it may be useful to think of its full generality when working with -- a 'Monad' transformer stack: -- -- @ -- 'previews' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m ('Maybe' r) -- 'previews' :: 'MonadReader' s m => 'Fold' s a -> (a -> r) -> m ('Maybe' r) -- 'previews' :: 'MonadReader' s m => 'Lens'' s a -> (a -> r) -> m ('Maybe' r) -- 'previews' :: 'MonadReader' s m => 'Iso'' s a -> (a -> r) -> m ('Maybe' r) -- 'previews' :: 'MonadReader' s m => 'Traversal'' s a -> (a -> r) -> m ('Maybe' r) -- @ previews :: MonadReader s m => Getting (First r) s a -> (a -> r) -> m (Maybe r) previews l f = asks (getFirst . foldMapOf l (First #. Just . f)) {-# INLINE previews #-} -- | Retrieve a function of the first index and value targeted by an 'IndexedFold' or -- 'IndexedTraversal' (or 'Just' the result from an 'IndexedGetter' or 'IndexedLens'). -- See also ('^@?'). -- -- @ -- 'ipreviews' = 'views' '.' 'ipre' -- @ -- -- This is usually applied in the 'Control.Monad.Reader.Reader' -- 'Control.Monad.Monad' @(->) s@. -- -- @ -- 'ipreviews' :: 'IndexedGetter' i s a -> (i -> a -> r) -> s -> 'Maybe' r -- 'ipreviews' :: 'IndexedFold' i s a -> (i -> a -> r) -> s -> 'Maybe' r -- 'ipreviews' :: 'IndexedLens'' i s a -> (i -> a -> r) -> s -> 'Maybe' r -- 'ipreviews' :: 'IndexedTraversal'' i s a -> (i -> a -> r) -> s -> 'Maybe' r -- @ -- -- However, it may be useful to think of its full generality when working with -- a 'Control.Monad.Monad' transformer stack: -- -- @ -- 'ipreviews' :: 'MonadReader' s m => 'IndexedGetter' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreviews' :: 'MonadReader' s m => 'IndexedFold' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreviews' :: 'MonadReader' s m => 'IndexedLens'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreviews' :: 'MonadReader' s m => 'IndexedTraversal'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- @ ipreviews :: MonadReader s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r) ipreviews l f = asks (getFirst . ifoldMapOf l (\i -> First #. Just . f i)) {-# INLINE ipreviews #-} ------------------------------------------------------------------------------ -- Preuse ------------------------------------------------------------------------------ -- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result -- from a 'Getter' or 'Lens') into the current state. -- -- @ -- 'preuse' = 'use' '.' 'pre' -- @ -- -- @ -- 'preuse' :: 'MonadState' s m => 'Getter' s a -> m ('Maybe' a) -- 'preuse' :: 'MonadState' s m => 'Fold' s a -> m ('Maybe' a) -- 'preuse' :: 'MonadState' s m => 'Lens'' s a -> m ('Maybe' a) -- 'preuse' :: 'MonadState' s m => 'Iso'' s a -> m ('Maybe' a) -- 'preuse' :: 'MonadState' s m => 'Traversal'' s a -> m ('Maybe' a) -- @ preuse :: MonadState s m => Getting (First a) s a -> m (Maybe a) preuse l = gets (preview l) {-# INLINE preuse #-} -- | 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. -- -- @ -- 'ipreuse' = 'use' '.' 'ipre' -- @ -- -- @ -- 'ipreuse' :: 'MonadState' s m => 'IndexedGetter' i s a -> m ('Maybe' (i, a)) -- 'ipreuse' :: 'MonadState' s m => 'IndexedFold' i s a -> m ('Maybe' (i, a)) -- 'ipreuse' :: 'MonadState' s m => 'IndexedLens'' i s a -> m ('Maybe' (i, a)) -- 'ipreuse' :: 'MonadState' s m => 'IndexedTraversal'' i s a -> m ('Maybe' (i, a)) -- @ ipreuse :: MonadState s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a)) ipreuse l = gets (ipreview l) {-# INLINE ipreuse #-} -- | Retrieve a function of the first value targeted by a 'Fold' or -- 'Traversal' (or 'Just' the result from a 'Getter' or 'Lens') into the current state. -- -- @ -- 'preuses' = 'uses' '.' 'pre' -- @ -- -- @ -- 'preuses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m ('Maybe' r) -- 'preuses' :: 'MonadState' s m => 'Fold' s a -> (a -> r) -> m ('Maybe' r) -- 'preuses' :: 'MonadState' s m => 'Lens'' s a -> (a -> r) -> m ('Maybe' r) -- 'preuses' :: 'MonadState' s m => 'Iso'' s a -> (a -> r) -> m ('Maybe' r) -- 'preuses' :: 'MonadState' s m => 'Traversal'' s a -> (a -> r) -> m ('Maybe' r) -- @ preuses :: MonadState s m => Getting (First r) s a -> (a -> r) -> m (Maybe r) preuses l f = gets (previews l f) {-# INLINE preuses #-} -- | Retrieve a function of the first index and value targeted by an 'IndexedFold' or -- 'IndexedTraversal' (or a function of 'Just' the index and result from an 'IndexedGetter' -- or 'IndexedLens') into the current state. -- -- @ -- 'ipreuses' = 'uses' '.' 'ipre' -- @ -- -- @ -- 'ipreuses' :: 'MonadState' s m => 'IndexedGetter' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreuses' :: 'MonadState' s m => 'IndexedFold' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreuses' :: 'MonadState' s m => 'IndexedLens'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreuses' :: 'MonadState' s m => 'IndexedTraversal'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- @ ipreuses :: MonadState s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r) ipreuses l f = gets (ipreviews l f) {-# INLINE ipreuses #-} ------------------------------------------------------------------------------ -- Profunctors ------------------------------------------------------------------------------ -- | This allows you to 'Control.Traversable.traverse' the elements of a pretty much any 'LensLike' construction in the opposite order. -- -- This will preserve indexes on 'Indexed' types and will give you the elements of a (finite) 'Fold' or 'Traversal' in the opposite order. -- -- This has no practical impact on a 'Getter', 'Setter', 'Lens' or 'Iso'. -- -- /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 l f = forwards #. l (Backwards #. f) {-# INLINE backwards #-} ------------------------------------------------------------------------------ -- Indexed Folds ------------------------------------------------------------------------------ -- | Fold an 'IndexedFold' or 'IndexedTraversal' by mapping indices and values to an arbitrary 'Monoid' with access -- to the @i@. -- -- When you don't need access to the index then 'foldMapOf' is more flexible in what it accepts. -- -- @ -- 'foldMapOf' l ≡ 'ifoldMapOf' l '.' 'const' -- @ -- -- @ -- 'ifoldMapOf' :: 'IndexedGetter' i s a -> (i -> a -> m) -> s -> m -- 'ifoldMapOf' :: 'Monoid' m => 'IndexedFold' i s a -> (i -> a -> m) -> s -> m -- 'ifoldMapOf' :: 'IndexedLens'' i s a -> (i -> a -> m) -> s -> m -- 'ifoldMapOf' :: 'Monoid' m => 'IndexedTraversal'' i s a -> (i -> a -> m) -> s -> m -- @ -- ifoldMapOf :: IndexedGetting i m s a -> (i -> a -> m) -> s -> m ifoldMapOf l = foldMapOf l .# Indexed {-# INLINE ifoldMapOf #-} -- | Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with -- access to the @i@. -- -- When you don't need access to the index then 'foldrOf' is more flexible in what it accepts. -- -- @ -- 'foldrOf' l ≡ 'ifoldrOf' l '.' 'const' -- @ -- -- @ -- 'ifoldrOf' :: 'IndexedGetter' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf' :: 'IndexedFold' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf' :: 'IndexedLens'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- @ ifoldrOf :: IndexedGetting i (Endo r) s a -> (i -> a -> r -> r) -> r -> s -> r ifoldrOf l = foldrOf l .# Indexed {-# INLINE ifoldrOf #-} -- | Left-associative fold of the parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with -- access to the @i@. -- -- When you don't need access to the index then 'foldlOf' is more flexible in what it accepts. -- -- @ -- 'foldlOf' l ≡ 'ifoldlOf' l '.' 'const' -- @ -- -- @ -- 'ifoldlOf' :: 'IndexedGetter' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf' :: 'IndexedFold' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf' :: 'IndexedLens'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf' :: 'IndexedTraversal'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- @ ifoldlOf :: IndexedGetting i (Dual (Endo r)) s a -> (i -> r -> a -> r) -> r -> s -> r ifoldlOf l f z = (flip appEndo z .# getDual) `rmap` ifoldMapOf l (\i -> Dual #. Endo #. flip (f i)) {-# INLINE ifoldlOf #-} -- | Return whether or not any element viewed through an 'IndexedFold' or 'IndexedTraversal' -- satisfy a predicate, with access to the @i@. -- -- When you don't need access to the index then 'anyOf' is more flexible in what it accepts. -- -- @ -- 'anyOf' l ≡ 'ianyOf' l '.' 'const' -- @ -- -- @ -- 'ianyOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'ianyOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'ianyOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'ianyOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ ianyOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool ianyOf l = anyOf l .# Indexed {-# INLINE ianyOf #-} -- | Return whether or not all 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 'allOf' is more flexible in what it accepts. -- -- @ -- 'allOf' l ≡ 'iallOf' l '.' 'const' -- @ -- -- @ -- 'iallOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'iallOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'iallOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'iallOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ iallOf :: IndexedGetting i All s a -> (i -> a -> Bool) -> s -> Bool iallOf l = allOf l .# Indexed {-# INLINE iallOf #-} -- | 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. -- -- @ -- 'traverseOf_' l ≡ 'Control.Lens.Traversal.itraverseOf' l '.' 'const' -- @ -- -- @ -- 'itraverseOf_' :: 'Functor' f => 'IndexedGetter' i s a -> (i -> a -> f r) -> s -> f () -- 'itraverseOf_' :: 'Applicative' f => 'IndexedFold' i s a -> (i -> a -> f r) -> s -> f () -- 'itraverseOf_' :: 'Functor' f => 'IndexedLens'' i s a -> (i -> a -> f r) -> s -> f () -- 'itraverseOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> (i -> a -> f r) -> s -> f () -- @ itraverseOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> (i -> a -> f r) -> s -> f () itraverseOf_ l = traverseOf_ l .# Indexed {-# INLINE itraverseOf_ #-} -- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the index, discarding the results -- (with the arguments flipped). -- -- @ -- 'iforOf_' ≡ 'flip' '.' 'itraverseOf_' -- @ -- -- When you don't need access to the index then 'forOf_' is more flexible in what it accepts. -- -- @ -- 'forOf_' l a ≡ 'iforOf_' l a '.' 'const' -- @ -- -- @ -- 'iforOf_' :: 'Functor' f => 'IndexedGetter' i s a -> s -> (i -> a -> f r) -> f () -- 'iforOf_' :: 'Applicative' f => 'IndexedFold' i s a -> s -> (i -> a -> f r) -> f () -- 'iforOf_' :: 'Functor' f => 'IndexedLens'' i s a -> s -> (i -> a -> f r) -> f () -- 'iforOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> s -> (i -> a -> f r) -> f () -- @ iforOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> s -> (i -> a -> f r) -> f () iforOf_ = flip . itraverseOf_ {-# INLINE iforOf_ #-} -- | Run monadic actions for each target of an 'IndexedFold' or 'IndexedTraversal' with access to the index, -- discarding the results. -- -- When you don't need access to the index then 'mapMOf_' is more flexible in what it accepts. -- -- @ -- 'mapMOf_' l ≡ 'Control.Lens.Setter.imapMOf' l '.' 'const' -- @ -- -- @ -- 'imapMOf_' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> m r) -> s -> m () -- 'imapMOf_' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> m r) -> s -> m () -- 'imapMOf_' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> m r) -> s -> m () -- 'imapMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m r) -> s -> m () -- @ imapMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> (i -> a -> m r) -> s -> m () imapMOf_ l = mapMOf_ l .# Indexed {-# INLINE imapMOf_ #-} -- | Run monadic actions for each target of an 'IndexedFold' or 'IndexedTraversal' with access to the index, -- discarding the results (with the arguments flipped). -- -- @ -- 'iforMOf_' ≡ 'flip' '.' 'imapMOf_' -- @ -- -- When you don't need access to the index then 'forMOf_' is more flexible in what it accepts. -- -- @ -- 'forMOf_' l a ≡ 'Control.Lens.Traversal.iforMOf' l a '.' 'const' -- @ -- -- @ -- 'iforMOf_' :: 'Monad' m => 'IndexedGetter' i s a -> s -> (i -> a -> m r) -> m () -- 'iforMOf_' :: 'Monad' m => 'IndexedFold' i s a -> s -> (i -> a -> m r) -> m () -- 'iforMOf_' :: 'Monad' m => 'IndexedLens'' i s a -> s -> (i -> a -> m r) -> m () -- 'iforMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> s -> (i -> a -> m r) -> m () -- @ iforMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> s -> (i -> a -> m r) -> m () iforMOf_ = flip . imapMOf_ {-# INLINE iforMOf_ #-} -- | Concatenate the results of a function of the elements of an 'IndexedFold' or 'IndexedTraversal' -- with access to the index. -- -- When you don't need access to the index then 'concatMapOf' is more flexible in what it accepts. -- -- @ -- 'concatMapOf' l ≡ 'iconcatMapOf' l '.' 'const' -- 'iconcatMapOf' ≡ 'ifoldMapOf' -- @ -- -- @ -- 'iconcatMapOf' :: 'IndexedGetter' i s a -> (i -> a -> [r]) -> s -> [r] -- 'iconcatMapOf' :: 'IndexedFold' i s a -> (i -> a -> [r]) -> s -> [r] -- 'iconcatMapOf' :: 'IndexedLens'' i s a -> (i -> a -> [r]) -> s -> [r] -- 'iconcatMapOf' :: 'IndexedTraversal'' i s a -> (i -> a -> [r]) -> s -> [r] -- @ iconcatMapOf :: IndexedGetting i [r] s a -> (i -> a -> [r]) -> s -> [r] iconcatMapOf = ifoldMapOf {-# INLINE iconcatMapOf #-} -- | The 'findOf' 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. -- -- When you don't need access to the index then 'findOf' is more flexible in what it accepts. -- -- @ -- 'findOf' l ≡ 'ifindOf' l '.' 'const' -- @ -- -- @ -- 'ifindOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- 'ifindOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- 'ifindOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- 'ifindOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- @ ifindOf :: IndexedGetting i (Endo (Maybe a)) s a -> (i -> a -> Bool) -> s -> Maybe a ifindOf l = findOf l .# Indexed {-# INLINE ifindOf #-} -- | /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. -- -- @ -- 'foldrOf'' l ≡ 'ifoldrOf'' l '.' 'const' -- @ -- -- @ -- 'ifoldrOf'' :: 'IndexedGetter' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf'' :: 'IndexedFold' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf'' :: 'IndexedLens'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf'' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- @ ifoldrOf' :: IndexedGetting i (Dual (Endo (r -> r))) s a -> (i -> a -> r -> r) -> r -> s -> r ifoldrOf' l f z0 xs = ifoldlOf l f' id xs z0 where f' i k x z = k $! f i x z {-# INLINE ifoldrOf' #-} -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/. -- -- When you don't need access to the index then 'foldlOf'' is more flexible in what it accepts. -- -- @ -- 'foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const' -- @ -- -- @ -- 'ifoldlOf'' :: 'IndexedGetter' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf'' :: 'IndexedFold' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf'' :: 'IndexedLens'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf'' :: 'IndexedTraversal'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- @ ifoldlOf' :: IndexedGetting i (Endo (r -> r)) s a -> (i -> r -> a -> r) -> r -> s -> r ifoldlOf' l f z0 xs = ifoldrOf l f' id xs z0 where f' i x k z = k $! f i z x {-# INLINE ifoldlOf' #-} -- | Monadic fold right over the elements of a structure with an index. -- -- When you don't need access to the index then 'foldrMOf' is more flexible in what it accepts. -- -- @ -- 'foldrMOf' l ≡ 'ifoldrMOf' l '.' 'const' -- @ -- -- @ -- 'ifoldrMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> r -> m r) -> r -> s -> m r -- 'ifoldrMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> r -> m r) -> r -> s -> m r -- 'ifoldrMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> r -> m r) -> r -> s -> m r -- 'ifoldrMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> r -> m r) -> r -> s -> m r -- @ ifoldrMOf :: Monad m => IndexedGetting i (Dual (Endo (r -> m r))) s a -> (i -> a -> r -> m r) -> r -> s -> m r ifoldrMOf l f z0 xs = ifoldlOf l f' return xs z0 where f' i k x z = f i x z >>= k {-# INLINE ifoldrMOf #-} -- | Monadic fold over the elements of a structure with an index, associating to the left. -- -- When you don't need access to the index then 'foldlMOf' is more flexible in what it accepts. -- -- @ -- 'foldlMOf' l ≡ 'ifoldlMOf' l '.' 'const' -- @ -- -- @ -- 'ifoldlMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> r -> a -> m r) -> r -> s -> m r -- 'ifoldlMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> r -> a -> m r) -> r -> s -> m r -- 'ifoldlMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> r -> a -> m r) -> r -> s -> m r -- 'ifoldlMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> r -> a -> m r) -> r -> s -> m r -- @ ifoldlMOf :: Monad m => IndexedGetting i (Endo (r -> m r)) s a -> (i -> r -> a -> m r) -> r -> s -> m r ifoldlMOf l f z0 xs = ifoldrOf l f' return xs z0 where f' i x k z = f i z x >>= k {-# INLINE ifoldlMOf #-} -- | Extract the key-value pairs from a structure. -- -- When you don't need access to the indices in the result, then 'toListOf' is more flexible in what it accepts. -- -- @ -- 'toListOf' l ≡ 'map' 'fst' '.' 'itoListOf' l -- @ -- -- @ -- 'itoListOf' :: 'IndexedGetter' i s a -> s -> [(i,a)] -- 'itoListOf' :: 'IndexedFold' i s a -> s -> [(i,a)] -- 'itoListOf' :: 'IndexedLens'' i s a -> s -> [(i,a)] -- 'itoListOf' :: 'IndexedTraversal'' i s a -> s -> [(i,a)] -- @ itoListOf :: IndexedGetting i (Endo [(i,a)]) s a -> s -> [(i,a)] itoListOf l = ifoldrOf l (\i a -> ((i,a):)) [] {-# INLINE itoListOf #-} -- | An infix version of 'itoListOf'. -- @ -- ('^@..') :: s -> 'IndexedGetter' i s a -> [(i,a)] -- ('^@..') :: s -> 'IndexedFold' i s a -> [(i,a)] -- ('^@..') :: s -> 'IndexedLens'' i s a -> [(i,a)] -- ('^@..') :: s -> 'IndexedTraversal'' i s a -> [(i,a)] -- @ (^@..) :: s -> IndexedGetting i (Endo [(i,a)]) s a -> [(i,a)] s ^@.. l = ifoldrOf l (\i a -> ((i,a):)) [] s {-# INLINE (^@..) #-} -- | Perform a safe 'head' (with index) of an 'IndexedFold' or 'IndexedTraversal' or retrieve 'Just' the index and result -- from an 'IndexedGetter' or 'IndexedLens'. -- -- When using a 'IndexedTraversal' as a partial 'IndexedLens', or an 'IndexedFold' as a partial 'IndexedGetter' this can be a convenient -- way to extract the optional value. -- -- @ -- ('^@?') :: s -> 'IndexedGetter' i s a -> 'Maybe' (i, a) -- ('^@?') :: s -> 'IndexedFold' i s a -> 'Maybe' (i, a) -- ('^@?') :: s -> 'IndexedLens'' i s a -> 'Maybe' (i, a) -- ('^@?') :: s -> 'IndexedTraversal'' i s a -> 'Maybe' (i, a) -- @ (^@?) :: s -> IndexedGetting i (Endo (Maybe (i, a))) s a -> Maybe (i, a) s ^@? l = ifoldrOf l (\i x _ -> Just (i,x)) Nothing s {-# INLINE (^@?) #-} -- | Perform an *UNSAFE* 'head' (with index) of an 'IndexedFold' or 'IndexedTraversal' assuming that it is there. -- -- @ -- ('^@?!') :: s -> 'IndexedGetter' i s a -> (i, a) -- ('^@?!') :: s -> 'IndexedFold' i s a -> (i, a) -- ('^@?!') :: s -> 'IndexedLens'' i s a -> (i, a) -- ('^@?!') :: s -> 'IndexedTraversal'' i s a -> (i, a) -- @ (^@?!) :: s -> IndexedGetting i (Endo (i, a)) s a -> (i, a) s ^@?! l = ifoldrOf l (\i x _ -> (i,x)) (error "(^@?!): empty Fold") s {-# INLINE (^@?!) #-} ------------------------------------------------------------------------------- -- Converting to Folds ------------------------------------------------------------------------------- -- | Filter an 'IndexedFold' or 'IndexedGetter', obtaining an 'IndexedFold'. -- -- >>> [0,0,0,5,5,5]^..traversed.ifiltered (\i a -> i <= a) -- [0,5,5,5] -- -- Compose with 'filtered' to filter another 'IndexedLens', 'IndexedIso', 'IndexedGetter', 'IndexedFold' (or 'IndexedTraversal') with -- 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 p f = Indexed $ \i a -> if p i a then indexed f i a else pure a {-# INLINE ifiltered #-} -- | Obtain an 'IndexedFold' by taking elements from another -- 'IndexedFold', 'IndexedLens', 'IndexedGetter' or 'IndexedTraversal' while a predicate holds. -- -- @ -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedMonadicFold' i m s a -- @ 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 {-# INLINE itakingWhile #-} -- | Obtain an 'IndexedFold' by dropping elements from another 'IndexedFold', 'IndexedLens', 'IndexedGetter' or 'IndexedTraversal' while a predicate holds. -- -- @ -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- see notes -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- see notes -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedMonadicFold' i m s a -- @ -- -- Applying 'idroppingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still allow you to use it as a -- pseudo-'IndexedTraversal', but if you change the value of the targets to ones where the predicate returns -- '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 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 in (if b' then pure a else indexed f i a, b') {-# INLINE idroppingWhile #-} ------------------------------------------------------------------------------ -- Deprecated ------------------------------------------------------------------------------ -- | A deprecated alias for 'firstOf'. headOf :: Getting (First a) s a -> s -> Maybe a headOf l = getFirst #. foldMapOf l (First #. Just) {-# INLINE headOf #-} {-# DEPRECATED headOf "`headOf' will be removed after GHC 7.8 is released. (Use `preview' or `firstOf')" #-} ------------------------------------------------------------------------------ -- Misc. ------------------------------------------------------------------------------ skip :: a -> () skip _ = () {-# INLINE skip #-} lens-3.10/src/Control/Lens/Getter.hs0000644000000000000000000004273512226700613015474 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE NoPolyKinds #-} {-# LANGUAGE NoDataKinds #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Getter -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- -- 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: -- -- @type 'Getting' r s t a b = (a -> 'Accessor' r b) -> s -> 'Accessor' r t@ -- -- If we restrict access to knowledge about the type 'r' and can work for -- any b and t, we could get: -- -- @type 'Getter' s a = forall r. 'Getting' r s s a a@ -- -- But we actually hide the use of 'Accessor' behind a class 'Gettable' -- to 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@ -- -- Everything you can do with a function, you can do with a 'Getter', but -- note that because of the continuation passing style ('.') composes them -- in the opposite order. -- -- Since it is only a function, every 'Getter' obviously only retrieves a -- single value for a given input. -- ------------------------------------------------------------------------------- module Control.Lens.Getter ( -- * Getters Getter, IndexedGetter , Getting, IndexedGetting , Accessing -- * Building Getters , to -- * Combinators for Getters and Folds , (^.) , view, views , use, uses , listening, listenings -- * Indexed Getters -- ** Indexed Getter Combinators , (^@.) , iview, iviews , iuse, iuses , ilistening, ilistenings -- * Implementation Details , Contravariant(..) , coerce, coerced , Accessor(..) , Gettable ) where import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.Reader.Class as Reader import Control.Monad.State as State import Control.Monad.Writer as Writer import Data.Functor.Contravariant import Data.Profunctor import Data.Profunctor.Unsafe -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.List.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g infixl 8 ^., ^@. ------------------------------------------------------------------------------- -- Getters ------------------------------------------------------------------------------- -- | Build a 'Getter' from an arbitrary Haskell function. -- -- @ -- 'to' f '.' 'to' g ≡ 'to' (g '.' f) -- @ -- -- @ -- a '^.' 'to' f ≡ f a -- @ -- -- >>> a ^.to f -- f a -- -- >>> ("hello","world")^.to snd -- "world" -- -- >>> 5^.to succ -- 6 -- -- >>> (0, -5)^._2.to abs -- 5 to :: (s -> a) -> IndexPreservingGetter s a to f = dimap f coerce {-# INLINE to #-} -- | 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', -- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of -- the indexed variants, and it will just \"do the right thing\". -- -- Most 'Getter' combinators are able to be used with both a 'Getter' or a -- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be -- monomorphic in what we are going to extract with 'Control.Applicative.Const'. To be compatible -- with 'Lens', 'Control.Lens.Traversal.Traversal' and -- '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 -- 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 -- | Used to consume an 'Control.Lens.Fold.IndexedFold'. type IndexedGetting i m s a = Indexed i a (Accessor m a) -> s -> Accessor 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 ------------------------------------------------------------------------------- -- Getting Values ------------------------------------------------------------------------------- -- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or -- 'Lens' or the result of folding over all the results of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- at a monoidal value. -- -- @ -- 'view' '.' 'to' ≡ 'id' -- @ -- -- >>> view (to f) a -- f a -- -- >>> view _2 (1,"hello") -- "hello" -- -- >>> view (to succ) 5 -- 6 -- -- >>> view (_2._1) ("hello",("world","!!!")) -- "world" -- -- -- As 'view' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', -- It may be useful to think of it as having one of these more restricted signatures: -- -- @ -- 'view' :: 'Getter' s a -> s -> a -- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s m -> s -> m -- 'view' :: 'Control.Lens.Iso.Iso'' s a -> s -> a -- 'view' :: 'Lens'' s a -> s -> a -- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s m -> s -> m -- @ -- -- In a more general setting, such as when working with a 'Monad' transformer stack you can use: -- -- @ -- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a -- 'view' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> m a -- 'view' :: 'MonadReader' s m => 'Lens'' s a -> m a -- '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) {-# INLINE view #-} -- | View a function of the value pointed to by a 'Getter' or 'Lens' or the result of -- folding over the result of mapping the targets of a 'Control.Lens.Fold.Fold' or -- 'Control.Lens.Traversal.Traversal'. -- -- @ -- 'views' l f ≡ 'view' (l '.' 'to' f) -- @ -- -- >>> views (to f) g a -- g (f a) -- -- >>> views _2 length (1,"hello") -- 5 -- -- As 'views' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', -- It may be useful to think of it as having one of these more restricted signatures: -- -- @ -- 'views' :: 'Getter' s a -> (a -> r) -> s -> r -- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m -- 'views' :: 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> s -> r -- 'views' :: 'Lens'' s a -> (a -> r) -> s -> r -- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s a -> (a -> m) -> s -> m -- @ -- -- In a more general setting, such as when working with a 'Monad' transformer stack you can use: -- -- @ -- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a -- 'view' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> m a -- 'view' :: 'MonadReader' s m => 'Lens'' s a -> m a -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a -- @ -- -- @ -- '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)) {-# INLINE views #-} -- | View the value pointed to by a 'Getter' or 'Lens' or the -- result of folding over all the results of a 'Control.Lens.Fold.Fold' or -- 'Control.Lens.Traversal.Traversal' that points at a monoidal values. -- -- This is the same operation as 'view' with the arguments flipped. -- -- The fixity and semantics are such that subsequent field accesses can be -- performed with ('Prelude..'). -- -- >>> (a,b)^._2 -- b -- -- >>> ("hello","world")^._2 -- "world" -- -- >>> import Data.Complex -- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude -- 2.23606797749979 -- -- @ -- ('^.') :: s -> 'Getter' s a -> a -- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Fold.Fold' s m -> m -- ('^.') :: s -> 'Control.Lens.Iso.Iso'' s a -> a -- ('^.') :: s -> 'Lens'' s a -> a -- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Traversal.Traversal'' s m -> m -- @ (^.) :: s -> Getting a s a -> a s ^. l = runAccessor (l Accessor s) {-# INLINE (^.) #-} ------------------------------------------------------------------------------- -- MonadState ------------------------------------------------------------------------------- -- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso', or -- 'Getter' in the current state, or use a summary of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- to a monoidal value. -- -- >>> evalState (use _1) (a,b) -- a -- -- >>> evalState (use _1) ("hello","world") -- "hello" -- -- @ -- 'use' :: 'MonadState' s m => 'Getter' s a -> m a -- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r -- 'use' :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> m a -- 'use' :: 'MonadState' s m => 'Lens'' s a -> m a -- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s r -> m r -- @ use :: MonadState s m => Getting a s a -> m a use l = State.gets (view l) {-# INLINE use #-} -- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso' or -- 'Getter' in the current state, or use a summary of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that -- points to a monoidal value. -- -- >>> evalState (uses _1 length) ("hello","world") -- 5 -- -- @ -- 'uses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r -- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r -- 'uses' :: 'MonadState' s m => 'Lens'' s a -> (a -> r) -> m r -- 'uses' :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> m r -- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r -- @ -- -- @ -- '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 l f = State.gets (views l f) {-# INLINE uses #-} -- | This is a generalized form of 'listen' that only extracts the portion of -- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' -- then a monoidal summary of the parts of the log that are visited will be -- returned. -- -- @ -- 'listening' :: 'MonadWriter' w m => 'Getter' w u -> m a -> m (a, u) -- 'listening' :: 'MonadWriter' w m => 'Lens'' w u -> m a -> m (a, u) -- 'listening' :: 'MonadWriter' w m => 'Iso'' w u -> m a -> m (a, u) -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Fold' w u -> m a -> m (a, u) -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Traversal'' w u -> m a -> m (a, u) -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Prism'' w u -> m a -> m (a, u) -- @ listening :: MonadWriter w m => Getting u w u -> m a -> m (a, u) listening l m = do (a, w) <- listen m return (a, view l w) {-# INLINE listening #-} -- | This is a generalized form of 'listen' that only extracts the portion of -- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' -- then a monoidal summary of the parts of the log that are visited will be -- returned. -- -- @ -- 'ilistening' :: 'MonadWriter' w m => 'IndexedGetter' i w u -> m a -> m (a, (i, u)) -- 'ilistening' :: 'MonadWriter' w m => 'IndexedLens'' i w u -> m a -> m (a, (i, u)) -- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedFold' i w u -> m a -> m (a, (i, u)) -- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedTraversal'' i w u -> m a -> m (a, (i, u)) -- @ ilistening :: MonadWriter w m => IndexedGetting i (i, u) w u -> m a -> m (a, (i, u)) ilistening l m = do (a, w) <- listen m return (a, iview l w) {-# INLINE ilistening #-} -- | This is a generalized form of 'listen' that only extracts the portion of -- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' -- then a monoidal summary of the parts of the log that are visited will be -- returned. -- -- @ -- 'listenings' :: 'MonadWriter' w m => 'Getter' w u -> (u -> v) -> m a -> m (a, v) -- 'listenings' :: 'MonadWriter' w m => 'Lens'' w u -> (u -> v) -> m a -> m (a, v) -- 'listenings' :: 'MonadWriter' w m => 'Iso'' w u -> (u -> v) -> m a -> m (a, v) -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Fold' w u -> (u -> v) -> m a -> m (a, v) -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Traversal'' w u -> (u -> v) -> m a -> m (a, v) -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Prism'' w u -> (u -> v) -> m a -> m (a, v) -- @ listenings :: MonadWriter w m => Getting v w u -> (u -> v) -> m a -> m (a, v) listenings l uv m = do (a, w) <- listen m return (a, views l uv w) {-# INLINE listenings #-} -- | This is a generalized form of 'listen' that only extracts the portion of -- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' -- then a monoidal summary of the parts of the log that are visited will be -- returned. -- -- @ -- 'ilistenings' :: 'MonadWriter' w m => 'IndexedGetter' w u -> (i -> u -> v) -> m a -> m (a, v) -- 'ilistenings' :: 'MonadWriter' w m => 'IndexedLens'' w u -> (i -> u -> v) -> m a -> m (a, v) -- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedFold' w u -> (i -> u -> v) -> m a -> m (a, v) -- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v) -- @ ilistenings :: MonadWriter w m => IndexedGetting i v w u -> (i -> u -> v) -> m a -> m (a, v) ilistenings l iuv m = do (a, w) <- listen m return (a, iviews l iuv w) {-# INLINE ilistenings #-} ------------------------------------------------------------------------------ -- Indexed Getters ------------------------------------------------------------------------------ -- | View the index and value of an 'IndexedGetter' into the current environment as a pair. -- -- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of -- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. iview :: MonadReader s m => IndexedGetting i (i,a) s a -> m (i,a) iview l = asks (runAccessor #. l (Indexed $ \i -> Accessor #. (,) i)) {-# INLINE iview #-} -- | View a function of the index and value of an 'IndexedGetter' into the current environment. -- -- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. -- -- @ -- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf' -- @ iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r iviews l = views l .# Indexed {-# INLINE iviews #-} -- | Use the index and value of an 'IndexedGetter' into the current state as a pair. -- -- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of -- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. iuse :: MonadState s m => IndexedGetting i (i,a) s a -> m (i,a) iuse l = gets (runAccessor #. l (Indexed $ \i -> Accessor #. (,) i)) {-# INLINE iuse #-} -- | Use a function of the index and value of an 'IndexedGetter' into the current state. -- -- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r iuses l = uses l .# Indexed {-# INLINE iuses #-} -- | View the value pointed to by a 'Getter' or 'Lens'. -- -- This is the same operation as 'iview' with the arguments flipped. -- -- 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) -- @ -- -- 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 {-# INLINE (^@.) #-} -- | Coerce a 'Gettable' 'LensLike' to a 'Simple' 'LensLike'. This is useful -- when using a 'Traversal' that is not simple as a 'Getter' or a 'Fold'. coerced :: (Functor f, Contravariant f) => LensLike f s t a b -> LensLike' f s a coerced l f = coerce . l (coerce . f) lens-3.10/src/Control/Lens/Indexed.hs0000644000000000000000000005730112226700613015615 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# 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 #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Indexed -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- (The classes in here need to be defined together for @DefaultSignatures@ to work.) ------------------------------------------------------------------------------- module Control.Lens.Indexed ( -- * Indexing Indexable(..) , Conjoined(..) , Indexed(..) , (<.), (<.>), (.>) , reindexed , icompose , indexing , indexing64 -- * Indexed Functors , FunctorWithIndex(..) -- * Indexed Foldables , FoldableWithIndex(..) , ifolding -- ** Indexed Foldable Combinators , iany , iall , itraverse_ , ifor_ , imapM_ , iforM_ , iconcatMap , ifind , ifoldrM , ifoldlM , itoList -- * Converting to Folds , withIndex , asIndex -- * Restricting by Index , indices , index -- * Indexed Traversables , TraversableWithIndex(..) -- * Indexed Traversable Combinators , ifor , imapM , iforM , imapAccumR , imapAccumL ) where import Control.Applicative import Control.Applicative.Backwards import Control.Monad (void, liftM) import Control.Monad.Trans.State.Lazy as Lazy import Control.Lens.Fold 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 import Control.Lens.Setter 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.Map as Map import Data.Monoid import Data.Profunctor.Unsafe import Data.Sequence hiding (index) import Data.Traversable import Data.Tuple (swap) import Data.Vector (Vector) import qualified Data.Vector as V infixr 9 <.>, <., .> -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | Compose an 'Indexed' function with a non-indexed function. -- -- Mnemonically, the @<@ points to the indexing we want to preserve. (<.) :: Indexable i p => (Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r (<.) f g h = f . Indexed $ g . indexed h {-# INLINE (<.) #-} -- | Compose a non-indexed function with an 'Indexed' function. -- -- Mnemonically, the @>@ points to the indexing we want to preserve. -- -- 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@. (.>) :: (st -> r) -> (kab -> st) -> kab -> r (.>) = (.) {-# INLINE (.>) #-} -- | Remap the index. reindexed :: Indexable j p => (i -> j) -> (Indexed i a b -> r) -> p a b -> r reindexed ij f g = f . Indexed $ indexed g . ij {-# INLINE reindexed #-} -- | Composition of 'Indexed' functions. -- -- Mnemonically, the @\<@ and @\>@ points to the fact that we want to preserve the indices. (<.>) :: Indexable (i, j) p => (Indexed i s t -> r) -> (Indexed j a b -> s -> t) -> p a b -> r f <.> g = icompose (,) f g {-# INLINE (<.>) #-} -- | Composition of 'Indexed' functions with a user supplied function for combining indices. icompose :: Indexable p c => (i -> j -> p) -> (Indexed i s t -> r) -> (Indexed j a b -> s -> t) -> c a b -> r icompose ijk istr jabst cab = istr . Indexed $ \i -> jabst . Indexed $ \j -> indexed cab $ ijk i j {-# INLINE icompose #-} ------------------------------------------------------------------------------- -- Converting to Folds ------------------------------------------------------------------------------- -- | Fold a container with indices returning both the indices and the values. -- -- 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 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 f = Indexed $ \i _ -> coerce (indexed f i i) {-# INLINE asIndex #-} ------------------------------------------------------------------------------- -- Restricting by index ------------------------------------------------------------------------------- -- | This allows you to filter an 'IndexedFold', 'IndexedGetter', 'IndexedTraversal' or 'IndexedLens' based on a predicate -- on the indices. -- -- >>> ["hello","the","world","!!!"]^..traversed.indices even -- ["hello","world"] -- -- >>> 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 p f = Indexed $ \i a -> if p i then indexed f i a else pure a {-# INLINE indices #-} -- | This allows you to filter an 'IndexedFold', 'IndexedGetter', 'IndexedTraversal' or 'IndexedLens' based on an index. -- -- >>> ["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 j f = Indexed $ \i a -> if j == i then indexed f i a else pure a {-# INLINE index #-} ------------------------------------------------------------------------------- -- FunctorWithIndex ------------------------------------------------------------------------------- -- | A 'Functor' with an additional index. -- -- Instances must satisfy a modified form of the 'Functor' laws: -- -- @ -- 'imap' f '.' 'imap' g ≡ 'imap' (\\i -> f i '.' g i) -- 'imap' (\\_ a -> a) ≡ 'id' -- @ 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 default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b imap = iover itraversed {-# INLINE imap #-} #endif -- | 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 = conjoined mapped (isets imap) {-# INLINE imapped #-} ------------------------------------------------------------------------------- -- FoldableWithIndex ------------------------------------------------------------------------------- -- | A container that supports folding with an additional index. class Foldable f => FoldableWithIndex i f | f -> i where -- -- | Fold a container by mapping value to an arbitrary 'Monoid' with access to the index @i@. -- -- When you don't need access to the index then 'foldMap' is more flexible in what it accepts. -- -- @ -- 'foldMap' ≡ 'ifoldMap' '.' 'const' -- @ ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m #ifdef MPTC_DEFAULTS default ifoldMap :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m ifoldMap = ifoldMapOf itraversed {-# INLINE ifoldMap #-} #endif -- | The 'IndexedFold' of a 'FoldableWithIndex' container. ifolded :: IndexedFold i (f a) a ifolded = conjoined folded $ \f -> coerce . getFolding . ifoldMap (\i -> Folding #. indexed f i) {-# INLINE ifolded #-} -- | Right-associative fold of an indexed container with access to the index @i@. -- -- When you don't need access to the index then 'Data.Foldable.foldr' is more flexible in what it accepts. -- -- @ -- 'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const' -- @ ifoldr :: (i -> a -> b -> b) -> b -> f a -> b ifoldr f z t = appEndo (ifoldMap (\i -> Endo #. f i) t) z {-# INLINE ifoldr #-} -- | Left-associative fold of an indexed container with access to the index @i@. -- -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts. -- -- @ -- 'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const' -- @ ifoldl :: (i -> b -> a -> b) -> b -> f a -> b ifoldl f z t = appEndo (getDual (ifoldMap (\i -> Dual #. Endo #. flip (f i)) t)) z {-# INLINE ifoldl #-} -- | /Strictly/ fold right over the elements of a structure with access to the index @i@. -- -- When you don't need access to the index then 'foldr'' is more flexible in what it accepts. -- -- @ -- 'foldr'' ≡ 'ifoldr'' '.' 'const' -- @ ifoldr' :: (i -> a -> b -> b) -> b -> f a -> b ifoldr' f z0 xs = ifoldl f' id xs z0 where f' i k x z = k $! f i x z {-# INLINE ifoldr' #-} -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts. -- -- @ -- 'Control.Lens.Fold.foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const' -- @ ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b ifoldl' f z0 xs = ifoldr f' id xs z0 where f' i x k z = k $! f i z x {-# 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. -- -- @ -- 'any' ≡ 'iany' '.' 'const' -- @ iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool iany f = getAny #. ifoldMap (\i -> Any #. f i) {-# INLINE iany #-} -- | Return whether or not all elements in a container satisfy a predicate, with access to the index @i@. -- -- When you don't need access to the index then 'all' is more flexible in what it accepts. -- -- @ -- 'all' ≡ 'iall' '.' 'const' -- @ iall :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool iall f = getAll #. ifoldMap (\i -> All #. f i) {-# INLINE iall #-} -- | 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. -- -- @ -- 'traverse_' l = 'itraverse' '.' 'const' -- @ itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f () itraverse_ f = getTraversed #. ifoldMap (\i -> Traversed #. void . f i) {-# INLINE itraverse_ #-} -- | Traverse elements with access to the index @i@, discarding the results (with the arguments flipped). -- -- @ -- 'ifor_' ≡ 'flip' 'itraverse_' -- @ -- -- When you don't need access to the index then 'for_' is more flexible in what it accepts. -- -- @ -- 'for_' a ≡ 'ifor_' a '.' 'const' -- @ ifor_ :: (FoldableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f () ifor_ = flip itraverse_ {-# INLINE ifor_ #-} -- | Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, -- discarding the results. -- -- When you don't need access to the index then 'Control.Lens.Fold.mapMOf_' is more flexible in what it accepts. -- -- @ -- 'mapM_' ≡ 'imapM' '.' 'const' -- @ imapM_ :: (FoldableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m () imapM_ f = getSequenced #. ifoldMap (\i -> Sequenced #. liftM skip . f i) {-# INLINE imapM_ #-} -- | Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, -- discarding the results (with the arguments flipped). -- -- @ -- 'iforM_' ≡ 'flip' 'imapM_' -- @ -- -- When you don't need access to the index then 'Control.Lens.Fold.forMOf_' is more flexible in what it accepts. -- -- @ -- 'Control.Lens.Fold.forMOf_' l a ≡ 'iforMOf' l a '.' 'const' -- @ iforM_ :: (FoldableWithIndex i t, Monad m) => t a -> (i -> a -> m b) -> m () iforM_ = flip imapM_ {-# INLINE iforM_ #-} -- | Concatenate the results of a function of the elements of an indexed container with access to the index. -- -- When you don't need access to the index then 'concatMap' is more flexible in what it accepts. -- -- @ -- 'concatMap' ≡ 'iconcatMap' '.' 'const' -- 'iconcatMap' ≡ 'ifoldMap' -- @ iconcatMap :: FoldableWithIndex i f => (i -> a -> [b]) -> f a -> [b] iconcatMap = ifoldMap {-# INLINE iconcatMap #-} -- | Searches a container with a predicate that is also supplied the index, returning 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 'find' is more flexible in what it accepts. -- -- @ -- 'find' ≡ 'ifind' '.' 'const' -- @ ifind :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Maybe (i, a) ifind p = ifoldr (\i a y -> if p i a then Just (i, a) else y) Nothing {-# INLINE ifind #-} -- | Monadic fold right over the elements of a structure with an index. -- -- When you don't need access to the index then 'foldrM' is more flexible in what it accepts. -- -- @ -- 'foldrM' ≡ 'ifoldrM' '.' 'const' -- @ ifoldrM :: (FoldableWithIndex i f, Monad m) => (i -> a -> b -> m b) -> b -> f a -> m b ifoldrM f z0 xs = ifoldl f' return xs z0 where f' i k x z = f i x z >>= k {-# INLINE ifoldrM #-} -- | Monadic fold over the elements of a structure with an index, associating to the left. -- -- When you don't need access to the index then 'foldlM' is more flexible in what it accepts. -- -- @ -- 'foldlM' ≡ 'ifoldlM' '.' 'const' -- @ ifoldlM :: (FoldableWithIndex i f, Monad m) => (i -> b -> a -> m b) -> b -> f a -> m b ifoldlM f z0 xs = ifoldr f' return xs z0 where f' i x k z = f i z x >>= k {-# INLINE ifoldlM #-} -- | Extract the key-value pairs from a structure. -- -- When you don't need access to the indices in the result, then 'Data.Foldable.toList' is more flexible in what it accepts. -- -- @ -- 'Data.Foldable.toList' ≡ 'Data.List.map' 'fst' '.' 'itoList' -- @ itoList :: FoldableWithIndex i f => f a -> [(i,a)] itoList = ifoldr (\i c -> ((i,c):)) [] {-# INLINE itoList #-} ------------------------------------------------------------------------------- -- TraversableWithIndex ------------------------------------------------------------------------------- -- | A 'Traversable' with an additional index. -- -- An instance must satisfy a (modified) form of the 'Traversable' laws: -- -- @ -- 'itraverse' ('const' 'Identity') ≡ 'Identity' -- 'fmap' ('itraverse' f) '.' 'itraverse' g ≡ 'Data.Functor.Compose.getCompose' '.' 'itraverse' (\\i -> 'Data.Functor.Compose.Compose' '.' 'fmap' (f i) '.' g i) -- @ 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 default itraverse :: Applicative f => (Int -> a -> f b) -> t a -> f (t b) itraverse = traversed .# Indexed {-# INLINE itraverse #-} #endif -- | The 'IndexedTraversal' of a 'TraversableWithIndex' container. itraversed :: IndexedTraversal i (t a) (t b) a b itraversed = conjoined traverse (itraverse . indexed) {-# INLINE itraversed #-} -- | Traverse with an index (and the arguments flipped). -- -- @ -- 'for' a ≡ 'ifor' a '.' 'const' -- 'ifor' ≡ 'flip' 'itraverse' -- @ ifor :: (TraversableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f (t b) ifor = flip itraverse {-# INLINE ifor #-} -- | Map each element of a structure to a monadic action, -- evaluate these actions from left to right, and collect the results, with access -- the index. -- -- When you don't need access to the index 'mapM' is more liberal in what it can accept. -- -- @ -- 'mapM' ≡ 'imapM' '.' 'const' -- @ imapM :: (TraversableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m (t b) imapM f = unwrapMonad #. itraverse (\i -> WrapMonad #. f i) {-# INLINE imapM #-} -- | Map each element of a structure to a monadic action, -- evaluate these actions from left to right, and collect the results, with access -- its position (and the arguments flipped). -- -- @ -- 'forM' a ≡ 'iforM' a '.' 'const' -- 'iforM' ≡ 'flip' 'imapM' -- @ iforM :: (TraversableWithIndex i t, Monad m) => t a -> (i -> a -> m b) -> m (t b) iforM = flip imapM {-# INLINE iforM #-} -- | Generalizes 'Data.Traversable.mapAccumR' to add access to the index. -- -- 'imapAccumROf' accumulates state from right to left. -- -- @ -- 'Control.Lens.Traversal.mapAccumR' ≡ 'imapAccumR' '.' 'const' -- @ imapAccumR :: TraversableWithIndex i t => (i -> s -> a -> (s, b)) -> s -> t a -> (s, t b) imapAccumR f s0 a = swap (Lazy.runState (forwards (itraverse (\i c -> Backwards (Lazy.state (\s -> swap (f i s c)))) a)) s0) {-# INLINE imapAccumR #-} -- | Generalizes 'Data.Traversable.mapAccumL' to add access to the index. -- -- 'imapAccumLOf' accumulates state from left to right. -- -- @ -- 'Control.Lens.Traversal.mapAccumLOf' ≡ 'imapAccumL' '.' 'const' -- @ imapAccumL :: TraversableWithIndex i t => (i -> s -> a -> (s, b)) -> s -> t a -> (s, t b) imapAccumL f s0 a = swap (Lazy.runState (itraverse (\i c -> Lazy.state (\s -> swap (f i s c))) a) s0) {-# INLINE imapAccumL #-} ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where imap f = Backwards . imap f . forwards {-# INLINE imap #-} instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where ifoldMap f = ifoldMap f . forwards {-# INLINE ifoldMap #-} instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where itraverse f = fmap Backwards . itraverse f . forwards {-# INLINE itraverse #-} instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where imap f = Reverse . imap f . getReverse {-# INLINE imap #-} instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where ifoldMap f = getDual . ifoldMap (\i -> Dual #. f i) . getReverse {-# INLINE ifoldMap #-} instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where itraverse f = fmap Reverse . forwards . itraverse (\i -> Backwards . f i) . getReverse {-# INLINE itraverse #-} instance FunctorWithIndex () Identity where imap f (Identity a) = Identity (f () a) {-# INLINE imap #-} instance FoldableWithIndex () Identity where ifoldMap f (Identity a) = f () a {-# INLINE ifoldMap #-} instance TraversableWithIndex () Identity where itraverse f (Identity a) = Identity <$> f () a {-# INLINE itraverse #-} instance FunctorWithIndex k ((,) k) where imap f (k,a) = (k, f k a) {-# INLINE imap #-} instance FoldableWithIndex k ((,) k) where ifoldMap = uncurry {-# INLINE ifoldMap #-} instance TraversableWithIndex k ((,) k) where itraverse f (k, a) = (,) k <$> f k a {-# 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 TraversableWithIndex Int [] where itraverse = itraverseOf traversed {-# INLINE itraverse #-} instance FunctorWithIndex () Maybe where imap f = fmap (f ()) {-# INLINE imap #-} instance FoldableWithIndex () Maybe where ifoldMap f = foldMap (f ()) {-# INLINE ifoldMap #-} instance TraversableWithIndex () Maybe where itraverse f = traverse (f ()) {-# 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 TraversableWithIndex Int Seq where itraverse = itraverseOf traversed {-# INLINE itraverse #-} instance FunctorWithIndex Int Vector where imap = V.imap {-# INLINE imap #-} instance FoldableWithIndex Int Vector where ifoldMap = ifoldMapOf itraversed {-# INLINE ifoldMap #-} ifoldr = V.ifoldr {-# INLINE ifoldr #-} ifoldl = V.ifoldl . flip {-# INLINE ifoldl #-} ifoldr' = V.ifoldr' {-# INLINE ifoldr' #-} ifoldl' = V.ifoldl' . flip {-# INLINE ifoldl' #-} instance TraversableWithIndex Int Vector where 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 TraversableWithIndex Int IntMap where #if MIN_VERSION_containers(0,5,0) itraverse = IntMap.traverseWithKey #else itraverse f = sequenceA . IntMap.mapWithKey f #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 TraversableWithIndex k (Map k) where #if MIN_VERSION_containers(0,5,0) itraverse = Map.traverseWithKey #else itraverse f = sequenceA . Map.mapWithKey f #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) => TraversableWithIndex k (HashMap k) where itraverse = HashMap.traverseWithKey {-# INLINE itraverse #-} instance FunctorWithIndex r ((->) r) where imap f g x = f x (g x) {-# INLINE imap #-} instance FunctorWithIndex i (Level i) where imap f = go where go (Two n l r) = Two n (go l) (go r) go (One i a) = One i (f i a) go Zero = Zero {-# INLINE imap #-} instance FoldableWithIndex i (Level i) where ifoldMap f = go where go (Two _ l r) = go l `mappend` go r go (One i a) = f i a go Zero = mempty {-# INLINE ifoldMap #-} instance TraversableWithIndex i (Level i) where itraverse f = go where go (Two n l r) = Two n <$> go l <*> go r go (One i a) = One i <$> f i a go Zero = pure Zero {-# INLINE itraverse #-} instance FunctorWithIndex i (Magma i t b) where imap f (MagmaAp x y) = MagmaAp (imap f x) (imap f y) imap _ (MagmaPure x) = MagmaPure x imap f (MagmaFmap xy x) = MagmaFmap xy (imap f x) imap f (Magma i a) = Magma i (f i a) {-# INLINE imap #-} instance FoldableWithIndex i (Magma i t b) where ifoldMap f (MagmaAp x y) = ifoldMap f x `mappend` ifoldMap f y ifoldMap _ MagmaPure{} = mempty ifoldMap f (MagmaFmap _ x) = ifoldMap f x ifoldMap f (Magma i a) = f i a {-# INLINE ifoldMap #-} instance TraversableWithIndex i (Magma i t b) where itraverse f (MagmaAp x y) = MagmaAp <$> itraverse f x <*> itraverse f y itraverse _ (MagmaPure x) = pure (MagmaPure x) itraverse f (MagmaFmap xy x) = MagmaFmap xy <$> itraverse f x itraverse f (Magma i a) = Magma i <$> f i a {-# INLINE itraverse #-} ------------------------------------------------------------------------------- -- Misc. ------------------------------------------------------------------------------- skip :: a -> () skip _ = () {-# INLINE skip #-} lens-3.10/src/Control/Lens/Internal.hs0000644000000000000000000000325712226700613016012 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2Types -- -- These are some of the explicit 'Functor' instances that leak into the -- type signatures of @Control.Lens@. You shouldn't need to import this -- module directly for most use-cases. -- ---------------------------------------------------------------------------- module Control.Lens.Internal ( module Control.Lens.Internal.Action , module Control.Lens.Internal.Bazaar , module Control.Lens.Internal.Context , module Control.Lens.Internal.Fold , module Control.Lens.Internal.Getter , module Control.Lens.Internal.Indexed , module Control.Lens.Internal.Iso , module Control.Lens.Internal.Level , module Control.Lens.Internal.Magma , module Control.Lens.Internal.Prism , module Control.Lens.Internal.Review , module Control.Lens.Internal.Setter , module Control.Lens.Internal.Zoom ) where import Control.Lens.Internal.Action import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Fold import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Internal.Instances () import Control.Lens.Internal.Iso import Control.Lens.Internal.Level import Control.Lens.Internal.Magma import Control.Lens.Internal.Prism import Control.Lens.Internal.Review import Control.Lens.Internal.Setter import Control.Lens.Internal.Zoom {-# ANN module "HLint: ignore Use import/export shortcut" #-} lens-3.10/src/Control/Lens/Iso.hs0000644000000000000000000003533612226700613014773 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_bytestring #define MIN_VERSION_bytestring(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Iso -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Control.Lens.Iso ( -- * Isomorphism Lenses Iso, Iso' , AnIso, AnIso' -- * Isomorphism Construction , iso -- * Consuming Isomorphisms , from , cloneIso , withIso -- * Working with isomorphisms , au , auf , under , mapping -- ** Common Isomorphisms , simple , non , anon , enum , curried, uncurried , flipped , Swapped(..) , Strict(..) , Reversing(..), reversed , involuted -- ** Uncommon Isomorphisms , magma , imagma , Magma -- ** Contravariant functors , contramapping -- * Profunctors , Profunctor(dimap,rmap,lmap) , dimapping , lmapping , rmapping ) where 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.Type import Control.Monad.State.Lazy as Lazy import Control.Monad.State.Strict as Strict import Control.Monad.Writer.Lazy as Lazy 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.Text as StrictT hiding (reverse) import Data.Text.Lazy as LazyT hiding (reverse) import Data.Tuple (swap) import Data.Maybe import Data.Profunctor import Data.Profunctor.Unsafe {-# ANN module "HLint: ignore Use on" #-} -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Map as Map -- >>> import Data.Foldable -- >>> import Data.Monoid ---------------------------------------------------------------------------- -- Isomorphisms ----------------------------------------------------------------------------- -- | 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) -- | A 'Simple' 'AnIso'. type AnIso' s a = AnIso s s a a -- | Build a simple isomorphism from a pair of inverse functions. -- -- @ -- '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 -- @ iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) {-# INLINE iso #-} ---------------------------------------------------------------------------- -- Consuming Isomorphisms ----------------------------------------------------------------------------- -- | Invert an isomorphism. -- -- @ -- 'from' ('from' l) ≡ l -- @ from :: AnIso s t a b -> Iso b a t s from l = withIso l $ \ sa bt -> iso bt sa {-# INLINE from #-} -- | 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) {-# INLINE withIso #-} -- | Convert from 'AnIso' back to any 'Iso'. -- -- This is useful when you need to store an isomorphism as a data type inside a container -- and later reconstitute it as an overloaded function. -- -- See '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 {-# INLINE cloneIso #-} ----------------------------------------------------------------------------- -- Isomorphisms families as Lenses ----------------------------------------------------------------------------- -- | Based on 'Control.Lens.Wrapped.ala' from Conor McBride's work on Epigram. -- -- This version is generalized to accept any 'Iso', not just a @newtype@. -- -- >>> au (wrapping 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) {-# INLINE au #-} -- | Based on @ala'@ from Conor McBride's work on Epigram. -- -- This version is generalized to accept any 'Iso', not just a @newtype@. -- -- For a version you pass the name of the @newtype@ constructor to, see 'Control.Lens.Wrapped.alaf'. -- -- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator -- is 'au' with an extra function argument. -- -- >>> auf (wrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10 auf :: AnIso s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t auf k = withIso k $ \ sa bt f g e -> bt (f (sa . g) e) {-# INLINE auf #-} -- | The opposite of working 'Control.Lens.Setter.over' a 'Setter' is working 'under' an isomorphism. -- -- @ -- 'under' ≡ 'Control.Lens.Setter.over' '.' 'from' -- @ -- -- @ -- 'under' :: 'Iso' s t a b -> (t -> s) -> b -> a -- @ under :: AnIso s t a b -> (t -> s) -> b -> a under k = withIso k $ \ sa bt ts -> sa . ts . bt {-# INLINE under #-} ----------------------------------------------------------------------------- -- Isomorphisms ----------------------------------------------------------------------------- -- | This isomorphism can be used to convert to or from an instance of 'Enum'. -- -- >>> LT^.from enum -- 0 -- -- >>> 97^.enum :: Char -- 'a' -- -- Note: this is only an isomorphism from the numeric range actually used -- and it is a bit of a pleasant fiction, since there are questionable -- 'Enum' instances for 'Double', and 'Float' that exist solely for -- @[1.0 .. 4.0]@ sugar and the instances for those and 'Integer' don't -- cover all values in their range. enum :: Enum a => Iso' Int a enum = iso toEnum fromEnum {-# INLINE enum #-} -- | This can be used to lift any 'Iso' into an arbitrary 'Functor'. mapping :: Functor f => AnIso s t a b -> Iso (f s) (f t) (f a) (f b) mapping k = withIso k $ \ sa bt -> iso (fmap sa) (fmap bt) {-# INLINE mapping #-} -- | Composition with this isomorphism is occasionally useful when your 'Lens', -- 'Control.Lens.Traversal.Traversal' or 'Iso' has a constraint on an unused -- argument to force that argument to agree with the -- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness. simple :: Iso' a a simple = id {-# INLINE simple #-} -- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@, then @'non' v@ is an isomorphism from -- @'Maybe' a'@ to @a@. -- -- 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. -- -- >>> Map.fromList [("hello",1)] & at "hello" . non 0 +~ 2 -- fromList [("hello",3)] -- -- >>> Map.fromList [("hello",1)] & at "hello" . non 0 -~ 1 -- fromList [] -- -- >>> Map.fromList [("hello",1)] ^. at "hello" . non 0 -- 1 -- -- >>> Map.fromList [] ^. at "hello" . non 0 -- 0 -- -- This combinator is also particularly useful when working with nested maps. -- -- /e.g./ When you want to create the nested 'Data.Map.Map' when it is missing: -- -- >>> Map.empty & at "hello" . non Map.empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- -- and when have deleting the last entry from the nested 'Data.Map.Map' mean that we -- should delete its entry from the surrounding one: -- -- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing -- fromList [] non :: Eq a => a -> Iso' (Maybe a) a non a = anon a (a==) {-# INLINE non #-} -- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate. -- -- This function assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@. -- -- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- -- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing -- fromList [] anon :: a -> (a -> Bool) -> Iso' (Maybe a) a anon a p = iso (fromMaybe a) go where go b | p b = Nothing | otherwise = Just b {-# INLINE anon #-} -- | The canonical isomorphism for currying and uncurrying a function. -- -- @ -- 'curried' = 'iso' 'curry' 'uncurry' -- @ -- -- >>> (fst^.curried) 3 4 -- 3 -- -- >>> view curried fst 3 4 -- 3 curried :: Iso ((a,b) -> c) ((d,e) -> f) (a -> b -> c) (d -> e -> f) curried = iso curry uncurry {-# INLINE curried #-} -- | The canonical isomorphism for uncurrying and currying a function. -- -- @ -- 'uncurried' = 'iso' 'uncurry' 'curry' -- @ -- -- @ -- 'uncurried' = 'from' 'curried' -- @ -- -- >>> ((+)^.uncurried) (1,2) -- 3 uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a,b) -> c) ((d,e) -> f) uncurried = iso uncurry curry {-# INLINE uncurried #-} -- | The isomorphism for flipping a function. -- -- >>>((,)^.flipped) 1 2 -- (2,1) flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c') flipped = iso flip flip {-# INLINE flipped #-} -- | This class provides for symmetric bifunctors. class Bifunctor p => Swapped p where -- | -- @ -- 'swapped' '.' 'swapped' ≡ 'id' -- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f -- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g -- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f -- @ -- -- >>> (1,2)^.swapped -- (2,1) swapped :: Iso (p a b) (p c d) (p b a) (p d c) instance Swapped (,) where swapped = iso swap swap instance Swapped Either where swapped = iso (either Right Left) (either Right Left) -- | 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 instance Strict LazyB.ByteString StrictB.ByteString where #if MIN_VERSION_bytestring(0,10,0) strict = iso LazyB.toStrict LazyB.fromStrict #else strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return) #endif {-# INLINE strict #-} instance Strict LazyT.Text StrictT.Text where strict = iso LazyT.toStrict LazyT.fromStrict {-# INLINE strict #-} instance Strict (Lazy.StateT s m a) (Strict.StateT s m a) where strict = iso (Strict.StateT . Lazy.runStateT) (Lazy.StateT . Strict.runStateT) {-# INLINE strict #-} instance Strict (Lazy.WriterT w m a) (Strict.WriterT w m a) where strict = iso (Strict.WriterT . Lazy.runWriterT) (Lazy.WriterT . Strict.runWriterT) {-# INLINE strict #-} instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST) {-# INLINE strict #-} -- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal. -- -- >>> "live" ^. reversed -- "evil" -- -- >>> "live" & reversed %~ ('d':) -- "lived" reversed :: Reversing a => Iso' a a reversed = involuted Iso.reversing -- | Given a function that is its own inverse, this gives you an 'Iso' using it in both directions. -- -- @ -- 'involuted' ≡ 'Control.Monad.join' 'iso' -- @ -- -- >>> "live" ^. involuted reverse -- "evil" -- -- >>> "live" & involuted reverse %~ ('d':) -- "lived" involuted :: (a -> a) -> Iso' a a involuted a = iso a a {-# INLINE involuted #-} ------------------------------------------------------------------------------ -- Magma ------------------------------------------------------------------------------ -- | This isomorphism can be used to inspect a 'Traversal' to see how it associates -- the structure and it can also be used to bake the 'Traversal' into a 'Magma' so -- that you can traverse over it multiple times. magma :: LensLike (Mafic a b) s t a b -> Iso s u (Magma Int t b a) (Magma j u c c) magma l = iso (runMafic `rmap` l sell) runMagma {-# INLINE magma #-} -- | 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 l = iso (runMolten #. l sell) (iextract .# Molten) {-# INLINE imagma #-} ------------------------------------------------------------------------------ -- Contravariant ------------------------------------------------------------------------------ -- | Lift an 'Iso' into a 'Contravariant' functor. -- -- @ -- contramapping :: 'Contravariant' f => 'Iso' s t a b -> 'Iso' (f a) (f b) (f s) (f t) -- contramapping :: 'Contravariant' f => 'Iso'' s a -> 'Iso'' (f a) (f s) -- @ contramapping :: Contravariant f => AnIso s t a b -> Iso (f a) (f b) (f s) (f t) contramapping f = withIso f $ \ sa bt -> iso (contramap sa) (contramap bt) {-# INLINE contramapping #-} ------------------------------------------------------------------------------ -- Profunctor ------------------------------------------------------------------------------ -- | Lift two 'Iso's into both arguments of a 'Profunctor' simultaneously. -- -- @ -- dimapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' s' t' a' b' -> 'Iso' (p a s') (p b t') (p s a') (p t b') -- dimapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p a s') (p s a') -- @ dimapping :: Profunctor p => AnIso s t a b -> AnIso s' t' a' b' -> Iso (p a s') (p b t') (p s a') (p t b') dimapping f g = withIso f $ \ s'a' b't' -> withIso g $ \ sa bt -> iso (dimap s'a' sa) (dimap b't' bt) {-# INLINE dimapping #-} -- | Lift an 'Iso' contravariantly into the left argument of a 'Profunctor'. -- -- @ -- lmapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' (p a x) (p b y) (p s x) (p t y) -- lmapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' (p a x) (p s x) -- @ lmapping :: Profunctor p => AnIso s t a b -> Iso (p a x) (p b y) (p s x) (p t y) lmapping f = withIso f $ \ sa bt -> iso (lmap sa) (lmap bt) {-# INLINE lmapping #-} -- | Lift an 'Iso' covariantly into the right argument of a 'Profunctor'. -- -- @ -- rmapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' (p x s) (p y t) (p x a) (p y b) -- rmapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' (p x s) (p x a) -- @ rmapping :: Profunctor p => AnIso s t a b -> Iso (p x s) (p y t) (p x a) (p y b) rmapping g = withIso g $ \ sa bt -> iso (rmap sa) (rmap bt) {-# INLINE rmapping #-} lens-3.10/src/Control/Lens/Lens.hs0000644000000000000000000010754112226700613015140 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- A @'Lens' s t a b@ is a purely functional reference. -- -- While a 'Control.Lens.Traversal.Traversal' could be used for -- 'Control.Lens.Getter.Getting' like a valid 'Control.Lens.Fold.Fold', -- it wasn't a valid 'Control.Lens.Getter.Getter' as 'Applicative' wasn't a superclass of -- 'Control.Lens.Getter.Gettable'. -- -- 'Functor', however is the superclass of both. -- -- @ -- type 'Lens' s t a b = forall f. 'Functor' f => (a -> f b) -> s -> f t -- @ -- -- Every 'Lens' is a valid 'Control.Lens.Setter.Setter'. -- -- Every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a -- 'Control.Lens.Fold.Fold' that doesn't use the 'Applicative' or -- 'Control.Lens.Getter.Gettable'. -- -- Every 'Lens' is a valid 'Control.Lens.Traversal.Traversal' that only uses -- the 'Functor' part of the 'Applicative' it is supplied. -- -- Every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a valid -- 'Control.Lens.Getter.Getter', since 'Functor' is a superclass of 'Control.Lens.Getter.Gettable'. -- -- Since every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a -- valid 'Control.Lens.Getter.Getter' it follows that it must view exactly one element in the -- structure. -- -- The 'Lens' laws follow from this property and the desire for it to act like -- a 'Data.Traversable.Traversable' when used as a -- 'Control.Lens.Traversal.Traversal'. -- -- In the examples below, 'getter' and 'setter' are supplied as example getters -- and setters, and are not actual functions supplied by this package. ------------------------------------------------------------------------------- module Control.Lens.Lens ( -- * Lenses Lens, Lens' , IndexedLens, IndexedLens' -- ** Concrete Lenses , ALens, ALens' , AnIndexedLens, AnIndexedLens' -- * Combinators , lens, ilens, iplens , (%%~), (%%=) , (%%@~), (%%@=) , (<%@~), (<%@=) , (<<%@~), (<<%@=) -- * Lateral Composition , choosing , chosen , alongside , inside -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (~) , (<<%~), (<<.~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=) , (<<%=), (<<.=) , (<<~) -- * Cloning Lenses , cloneLens , cloneIndexPreservingLens , cloneIndexedLens -- * ALens Combinators , storing , (^#) , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~) , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=) -- * Common Lenses , devoid , united -- * Context , Context(..) , Context' , locus ) where import Control.Applicative import Control.Comonad import Control.Lens.Combinators import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.State as State import Data.Monoid import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Data.Void {-# ANN module "HLint: ignore Use ***" #-} -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h -- >>> let getter :: Expr -> Expr; getter = fun "getter" -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^# infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <%~, <<%~, <<.~, <#~, #~, #%~, <#%~, #%%~ infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <%=, <<%=, <<.=, <#=, #=, #%=, <#%=, #%%= infixr 2 <<~ ------------------------------------------------------------------------------- -- Lenses ------------------------------------------------------------------------------- -- | When you see this as an argument to a function, it expects a 'Lens'. -- -- This type can also be used when you need to store a 'Lens' in a container, -- since it is rank-1. You can turn them back into a 'Lens' with 'cloneLens', -- or use it directly with combinators like 'storing' and ('^#'). type ALens s t a b = LensLike (Pretext (->) a b) s t a b -- | @ -- type 'ALens'' = 'Simple' 'ALens' -- @ 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'' = 'Simple' ('AnIndexedLens' i) -- @ type AnIndexedLens' i s a = AnIndexedLens i s s a a -------------------------- -- Constructing Lenses -------------------------- -- | Build a 'Lens' from a getter and a setter. -- -- @ -- 'lens' :: 'Functor' f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t -- @ -- -- >>> s ^. lens getter setter -- getter s -- -- >>> s & lens getter setter .~ b -- setter s b -- -- >>> s & lens getter setter %~ f -- setter s (f (getter s)) -- lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} -- | 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 iplens sa sbt pafb = cotabulate $ \ws -> sbt (extract ws) <$> corep pafb (sa <$> ws) {-# INLINE iplens #-} -- | Build an 'IndexedLens' from a 'Control.Lens.Getter.Getter' and -- a 'Control.Lens.Setter.Setter'. ilens :: (s -> (i, a)) -> (s -> b -> t) -> IndexedLens i s t a b ilens sia sbt iafb s = sbt s <$> uncurry (indexed iafb) (sia s) {-# INLINE ilens #-} -- | ('%%~') can be used in one of two scenarios: -- -- When applied to a 'Lens', it can edit the target of the 'Lens' in a -- structure, extracting a functorial result. -- -- When applied to a 'Traversal', it can edit the -- targets of the traversals, extracting an applicative summary of its -- actions. -- -- For all that the definition of this combinator is just: -- -- @ -- ('%%~') ≡ 'id' -- @ -- -- It may be beneficial to think about it as if it had these even more -- restricted types, however: -- -- @ -- ('%%~') :: 'Functor' f => 'Control.Lens.Iso.Iso' s t a b -> (a -> f b) -> s -> f t -- ('%%~') :: 'Functor' f => 'Lens' s t a b -> (a -> f b) -> s -> f t -- ('%%~') :: 'Applicative' f => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> f b) -> s -> f t -- @ -- -- When applied to a 'Traversal', it can edit the -- targets of the traversals, extracting a supplemental monoidal summary -- of its actions, by choosing @f = ((,) m)@ -- -- @ -- ('%%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> (r, b)) -> s -> (r, t) -- ('%%~') :: '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) (%%~) = id {-# INLINE (%%~) #-} -- | Modify the target of a 'Lens' in the current state returning some extra -- information of type @r@ or modify all targets of a -- 'Control.Lens.Traversal.Traversal' in the current state, extracting extra -- information of type @r@ and return a monoidal summary of the changes. -- -- >>> runState (_1 %%= \x -> (f x, g x)) (a,b) -- (f a,(g a,b)) -- -- @ -- ('%%=') ≡ ('state' '.') -- @ -- -- It may be useful to think of ('%%='), instead, as having either of the -- following more restricted type signatures: -- -- @ -- ('%%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso' s s a b -> (a -> (r, b)) -> m r -- ('%%=') :: '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 #if MIN_VERSION_mtl(2,1,1) l %%= f = State.state (l f) #else l %%= f = do (r, s) <- State.gets (l f) State.put s return r #endif {-# INLINE (%%=) #-} ------------------------------------------------------------------------------- -- Common Lenses ------------------------------------------------------------------------------- -- | Lift a 'Lens' so it can run under a function. -- inside :: ALens s t a b -> Lens (e -> s) (e -> t) (e -> a) (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) {-# INLINE inside #-} -- | Merge two lenses, getters, setters, folds or traversals. -- -- @ -- 'chosen' ≡ 'choosing' 'id' 'id' -- @ -- -- @ -- 'choosing' :: 'Control.Lens.Getter.Getter' s a -> 'Control.Lens.Getter.Getter' s' a -> 'Control.Lens.Getter.Getter' ('Either' s s') a -- 'choosing' :: 'Control.Lens.Fold.Fold' s a -> 'Control.Lens.Fold.Fold' s' a -> 'Control.Lens.Fold.Fold' ('Either' s s') a -- 'choosing' :: 'Lens'' s a -> 'Lens'' s' a -> 'Lens'' ('Either' s s') a -- 'choosing' :: 'Control.Lens.Traversal.Traversal'' s a -> 'Control.Lens.Traversal.Traversal'' s' a -> 'Control.Lens.Traversal.Traversal'' ('Either' s s') a -- 'choosing' :: 'Control.Lens.Setter.Setter'' s a -> 'Control.Lens.Setter.Setter'' s' a -> 'Control.Lens.Setter.Setter'' ('Either' s s') a -- @ choosing :: Functor f => LensLike f s t a b -> LensLike f s' t' a b -> LensLike f (Either s s') (Either t t') a b choosing l _ f (Left a) = Left <$> l f a choosing _ r f (Right a') = Right <$> r f a' {-# INLINE choosing #-} -- | This is a 'Lens' that updates either side of an 'Either', where both sides have the same type. -- -- @ -- 'chosen' ≡ 'choosing' 'id' 'id' -- @ -- -- >>> Left a^.chosen -- a -- -- >>> Right a^.chosen -- a -- -- >>> Right "hello"^.chosen -- "hello" -- -- >>> Right a & chosen *~ b -- Right (a * b) -- -- @ -- 'chosen' :: 'Lens' ('Either' a a) ('Either' b b) a b -- 'chosen' f ('Left' a) = 'Left' '<$>' f a -- 'chosen' f ('Right' a) = 'Right' '<$>' f a -- @ chosen :: IndexPreservingLens (Either a a) (Either b b) a b chosen pafb = cotabulate $ \weaa -> corep (either id id `lmap` pafb) weaa <&> \b -> case extract weaa of Left _ -> Left b Right _ -> Right b {-# INLINE chosen #-} -- | 'alongside' makes a 'Lens' from two other lenses. -- -- >>> (Left a, Right b)^.alongside chosen chosen -- (a,b) -- -- >>> (Left a, Right b) & alongside chosen chosen .~ (c,d) -- (Left c,Right d) -- -- @ -- 'alongside' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b') -- @ alongside :: 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' {-# INLINE alongside #-} -- | This 'Lens' lets you 'view' the current 'pos' of any indexed -- store comonad and 'seek' to a new position. This reduces the API -- for working these instances to a single 'Lens'. -- -- @ -- 'ipos' w ≡ w 'Control.Lens.Getter.^.' 'locus' -- 'iseek' s w ≡ w '&' 'locus' 'Control.Lens.Setter..~' s -- 'iseeks' f w ≡ w '&' 'locus' 'Control.Lens.Setter.%~' f -- @ -- -- @ -- 'locus' :: 'Lens'' ('Context'' a s) a -- 'locus' :: 'Conjoined' p => 'Lens'' ('Pretext'' p a s) a -- 'locus' :: 'Conjoined' p => 'Lens'' ('PretextT'' p g a s) a -- @ locus :: IndexedComonadStore p => Lens (p a c s) (p b c s) a b locus f w = (`iseek` w) <$> f (ipos w) {-# INLINE locus #-} ------------------------------------------------------------------------------- -- Cloning Lenses ------------------------------------------------------------------------------- -- | Cloning a 'Lens' is one way to make sure you aren't given -- something weaker, such as a 'Control.Lens.Traversal.Traversal' and can be -- used as a way to pass around lenses that have to be monomorphic in @f@. -- -- Note: This only accepts a proper 'Lens'. -- -- >>> let example l x = set (cloneLens l) (x^.cloneLens l + 1) x in example _2 ("hello",1,"you") -- ("hello",2,"you") cloneLens :: ALens s t a b -> Lens s t a b cloneLens l afb s = runPretext (l sell s) afb {-# INLINE cloneLens #-} -- | Clone a 'Lens' as an 'IndexedPreservingLens' that just passes through whatever -- index is on any 'IndexedLens', 'IndexedFold', 'IndexedGetter' or 'IndexedTraversal' it is composed with. cloneIndexPreservingLens :: ALens s t a b -> IndexPreservingLens s t a b cloneIndexPreservingLens l pafb = cotabulate $ \ws -> runPretext (l sell (extract ws)) $ \a -> corep pafb (a <$ ws) {-# INLINE cloneIndexPreservingLens #-} -- | Clone an 'IndexedLens' as an 'IndexedLens' with the same index. cloneIndexedLens :: AnIndexedLens i s t a b -> IndexedLens i s t a b cloneIndexedLens l f s = runPretext (l sell s) (Indexed (indexed f)) {-# INLINE cloneIndexedLens #-} ------------------------------------------------------------------------------- -- Setting and Remembering ------------------------------------------------------------------------------- -- | Modify the target of a 'Lens' and return the result. -- -- When you do not need the result of the addition, ('Control.Lens.Setter.%~') is more flexible. -- -- @ -- ('<%~') :: 'Lens' s t a b -> (a -> b) -> s -> (b, t) -- ('<%~') :: '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) l <%~ f = l $ rmap (\t -> (t, t)) f {-# INLINE (<%~) #-} -- | Increment the target of a numerically valued 'Lens' and return the result. -- -- When you do not need the result of the addition, ('Control.Lens.Setter.+~') is more flexible. -- -- @ -- ('<+~') :: '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) l <+~ a = l <%~ (+ a) {-# INLINE (<+~) #-} -- | Decrement the target of a numerically valued 'Lens' and return the result. -- -- When you do not need the result of the subtraction, ('Control.Lens.Setter.-~') is more flexible. -- -- @ -- ('<-~') :: '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) l <-~ a = l <%~ subtract a {-# INLINE (<-~) #-} -- | Multiply the target of a numerically valued 'Lens' and return the result. -- -- When you do not need the result of the multiplication, ('Control.Lens.Setter.*~') is more -- flexible. -- -- @ -- ('<*~') :: '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) l <*~ a = l <%~ (* a) {-# INLINE (<*~) #-} -- | Divide the target of a fractionally valued 'Lens' and return the result. -- -- When you do not need the result of the division, ('Control.Lens.Setter.//~') is more flexible. -- -- @ -- (' 'Lens'' s a -> a -> s -> (a, s) -- (' 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ ( Overloading (->) q ((,)a) s t a a -> a -> q s (a, t) l '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) 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. -- -- @ -- ('<^^~') :: ('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) 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. -- -- @ -- ('<**~') :: '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) l <**~ a = l <%~ (** a) {-# INLINE (<**~) #-} -- | Logically '||' a Boolean valued 'Lens' and return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.||~') is more flexible. -- -- @ -- ('<||~') :: '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) l <||~ b = l <%~ (|| b) {-# INLINE (<||~) #-} -- | Logically '&&' a Boolean valued 'Lens' and return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.&&~') is more flexible. -- -- @ -- ('<&&~') :: '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) l <&&~ b = l <%~ (&& b) {-# INLINE (<&&~) #-} -- | Modify the target of a 'Lens', but return the old value. -- -- When you do not need the result of the addition, ('Control.Lens.Setter.%~') is more flexible. -- -- @ -- ('<<%~') :: 'Lens' s t a b -> (a -> b) -> s -> (a, t) -- ('<<%~') :: '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) (<<%~) l = l . lmap (\a -> (a, a)) . second' {-# INLINE (<<%~) #-} -- | Modify the target of a 'Lens', but return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.%~') is more flexible. -- -- @ -- ('<<.~') :: 'Lens' s t a b -> b -> s -> (a, t) -- ('<<.~') :: '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) l <<.~ b = l $ \a -> (a, b) {-# INLINE (<<.~) #-} ------------------------------------------------------------------------------- -- Setting and Remembering State ------------------------------------------------------------------------------- -- | Modify the target of a 'Lens' into your 'Monad'\'s state by a user supplied -- function and return the result. -- -- When applied to a 'Control.Lens.Traversal.Traversal', it this will return a monoidal summary of all of the intermediate -- results. -- -- 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' 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 l <%= f = l %%= rmap (\b -> (b, b)) f {-# INLINE (<%=) #-} -- | Add to the target of a numerically valued 'Lens' into your 'Monad'\'s state -- and return the result. -- -- When you do not need the result of the addition, ('Control.Lens.Setter.+=') is more -- flexible. -- -- @ -- ('<+=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a -- ('<+=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a -- @ (<+=) :: (MonadState s m, Num a) => LensLike' ((,)a) s a -> a -> m a l <+= a = l <%= (+ a) {-# INLINE (<+=) #-} -- | Subtract from the target of a numerically valued 'Lens' into your 'Monad'\'s -- state and return the result. -- -- When you do not need the result of the subtraction, ('Control.Lens.Setter.-=') is more -- flexible. -- -- @ -- ('<-=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a -- ('<-=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a -- @ (<-=) :: (MonadState s m, Num a) => LensLike' ((,)a) s a -> a -> m a l <-= a = l <%= subtract a {-# INLINE (<-=) #-} -- | Multiply the target of a numerically valued 'Lens' into your 'Monad'\'s -- state and return the result. -- -- When you do not need the result of the multiplication, ('Control.Lens.Setter.*=') is more -- flexible. -- -- @ -- ('<*=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a -- ('<*=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a -- @ (<*=) :: (MonadState s m, Num a) => LensLike' ((,)a) s a -> a -> m a l <*= a = l <%= (* a) {-# INLINE (<*=) #-} -- | Divide the target of a fractionally valued 'Lens' into your 'Monad'\'s state -- and return the result. -- -- When you do not need the result of the division, ('Control.Lens.Setter.//=') is more flexible. -- -- @ -- (' 'Lens'' s a -> a -> m a -- (' 'Control.Lens.Iso.Iso'' s a -> a -> m a -- @ ( LensLike' ((,)a) s a -> a -> m a l 'Lens'' s a -> e -> m a -- ('<^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> m a -- @ (<^=) :: (MonadState s m, Num a, Integral e) => LensLike' ((,)a) s a -> e -> m a l <^= e = l <%= (^ e) {-# INLINE (<^=) #-} -- | Raise the target of a fractionally valued 'Lens' into your 'Monad'\'s state -- to an 'Integral' power and return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.^^=') is more flexible. -- -- @ -- ('<^^=') :: ('MonadState' s m, 'Fractional' b, 'Integral' e) => 'Lens'' s a -> e -> m a -- ('<^^=') :: ('MonadState' s m, 'Fractional' b, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> m a -- @ (<^^=) :: (MonadState s m, Fractional a, Integral e) => LensLike' ((,)a) s a -> e -> m a l <^^= e = l <%= (^^ e) {-# INLINE (<^^=) #-} -- | Raise the target of a floating-point valued 'Lens' into your 'Monad'\'s -- state to an arbitrary power and return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.**=') is more flexible. -- -- @ -- ('<**=') :: ('MonadState' s m, 'Floating' a) => 'Lens'' s a -> a -> m a -- ('<**=') :: ('MonadState' s m, 'Floating' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a -- @ (<**=) :: (MonadState s m, Floating a) => LensLike' ((,)a) s a -> a -> m a l <**= a = l <%= (** a) {-# INLINE (<**=) #-} -- | Logically '||' a Boolean valued 'Lens' into your 'Monad'\'s state and return -- the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.||=') is more flexible. -- -- @ -- ('<||=') :: 'MonadState' s m => 'Lens'' s 'Bool' -> 'Bool' -> m 'Bool' -- ('<||=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> m 'Bool' -- @ (<||=) :: MonadState s m => LensLike' ((,)Bool) s Bool -> Bool -> m Bool l <||= b = l <%= (|| b) {-# INLINE (<||=) #-} -- | Logically '&&' a Boolean valued 'Lens' into your 'Monad'\'s state and return -- the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.&&=') is more flexible. -- -- @ -- ('<&&=') :: 'MonadState' s m => 'Lens'' s 'Bool' -> 'Bool' -> m 'Bool' -- ('<&&=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> m 'Bool' -- @ (<&&=) :: MonadState s m => LensLike' ((,)Bool) s Bool -> Bool -> m Bool l <&&= b = l <%= (&& b) {-# INLINE (<&&=) #-} -- | Modify the target of a 'Lens' into your 'Monad'\'s state by a user supplied -- function and return the /old/ value that was replaced. -- -- 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. -- -- @ -- ('<<%=') :: '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' b) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a -- @ -- -- @('<<%=') :: '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 l <<%= f = l %%= lmap (\a -> (a,a)) (second' f) {-# INLINE (<<%=) #-} -- | Modify the target of a 'Lens' into your 'Monad'\'s state by a user supplied -- function and return the /old/ value that was replaced. -- -- 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. -- -- @ -- ('<<%=') :: '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 => LensLike ((,)a) s s a b -> b -> m a l <<.= b = l %%= \a -> (a,b) {-# INLINE (<<.=) #-} -- | Run a monadic action, and set the target of 'Lens' to its result. -- -- @ -- ('<<~') :: 'MonadState' s m => 'Control.Lens.Iso.Iso' s s a b -> m b -> m b -- ('<<~') :: 'MonadState' s m => 'Lens' s s a b -> m b -> m b -- @ -- -- NB: This is limited to taking an actual 'Lens' than admitting a 'Control.Lens.Traversal.Traversal' because -- there are potential loss of state issues otherwise. (<<~) :: MonadState s m => ALens s s a b -> m b -> m b l <<~ mb = do b <- mb modify $ \s -> ipeek b (l sell s) return b {-# INLINE (<<~) #-} -- | 'mappend' a monoidal value onto the end of the target of a 'Lens' and -- return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.<>~') is more flexible. (<<>~) :: Monoid m => Overloading (->) q ((,)m) s t m m -> m -> q s (m, t) l <<>~ m = l <%~ (`mappend` m) {-# INLINE (<<>~) #-} -- | 'mappend' a monoidal value onto the end of the target of a 'Lens' into -- your 'Monad'\'s state and return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.<>=') is more flexible. (<<>=) :: (MonadState s m, Monoid r) => LensLike' ((,)r) s r -> r -> m r l <<>= r = l <%= (`mappend` r) {-# INLINE (<<>=) #-} ------------------------------------------------------------------------------ -- Indexed ------------------------------------------------------------------------------ -- | Adjust the target of an 'IndexedLens' returning the intermediate result, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' and return a monoidal summary -- along with the answer. -- -- @l '<%~' f ≡ l '<%@~' 'const' f@ -- -- When you do not need access to the index then ('<%~') is more liberal in what it can accept. -- -- If you do not need the intermediate result, you can use ('Control.Lens.Setter.%@~') or even ('Control.Lens.Setter.%~'). -- -- @ -- ('<%@~') :: '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) l <%@~ f = l (Indexed $ \i a -> let b = f i a in (b, b)) {-# INLINE (<%@~) #-} -- | Adjust the target of an 'IndexedLens' returning the old value, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' and return a monoidal summary -- of the old values along with the answer. -- -- @ -- ('<<%@~') :: '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) l <<%@~ f = l $ Indexed $ \i a -> second' (f i) (a,a) {-# INLINE (<<%@~) #-} -- | Adjust the target of an 'IndexedLens' returning a supplementary result, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' and return a monoidal summary -- of the supplementary results and the answer. -- -- @('%%@~') ≡ 'Control.Lens.Indexed.withIndex'@ -- -- @ -- ('%%@~') :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t -- ('%%@~') :: 'Applicative' f => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t -- @ -- -- In particular, it is often useful to think of this function as having one of these even more -- restricted type signatures: -- -- @ -- ('%%@~') :: 'IndexedLens' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- ('%%@~') :: 'Monoid' r => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- @ (%%@~) :: IndexedLensLike i f s t a b -> (i -> a -> f b) -> s -> f t (%%@~) l = l .# Indexed {-# INLINE (%%@~) #-} -- | Adjust the target of an 'IndexedLens' returning a supplementary result, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' within the current state, and -- return a monoidal summary of the supplementary results. -- -- @l '%%@=' f ≡ 'state' (l '%%@~' f)@ -- -- @ -- ('%%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- ('%%@=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- @ (%%@=) :: MonadState s m => IndexedLensLike i ((,) r) s s a b -> (i -> a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,0) l %%@= f = State.state (l %%@~ f) #else l %%@= f = do (r, s) <- State.gets (l %%@~ f) State.put s return r #endif {-# INLINE (%%@=) #-} -- | Adjust the target of an 'IndexedLens' returning the intermediate result, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' within the current state, and -- return a monoidal summary of the intermediate results. -- -- @ -- ('<%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m b -- ('<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m b -- @ (<%@=) :: MonadState s m => IndexedLensLike i ((,) b) s s a b -> (i -> a -> b) -> m b l <%@= f = l %%@= \ i a -> let b = f i a in (b, b) {-# INLINE (<%@=) #-} -- | Adjust the target of an 'IndexedLens' returning the old value, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' within the current state, and -- return a monoidal summary of the old values. -- -- @ -- ('<<%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m a -- ('<<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m a -- @ (<<%@=) :: MonadState s m => IndexedLensLike i ((,) a) s s a b -> (i -> a -> b) -> m a #if MIN_VERSION_mtl(2,1,0) l <<%@= f = State.state (l (Indexed $ \ i a -> (a, f i a))) #else l <<%@= f = do (r, s) <- State.gets (l (Indexed $ \ i a -> (a, f i a))) State.put s return r #endif {-# INLINE (<<%@=) #-} ------------------------------------------------------------------------------ -- ALens Combinators ------------------------------------------------------------------------------ -- | A version of ('Control.Lens.Getter.^.') that works on 'ALens'. -- -- >>> ("hello","world")^#_2 -- "world" (^#) :: s -> ALens s t a b -> a s ^# l = ipos (l sell s) {-# INLINE (^#) #-} -- | A version of 'Control.Lens.Setter.set' that works on 'ALens'. -- -- >>> storing _2 "world" ("hello","there") -- ("hello","world") storing :: ALens s t a b -> b -> s -> t storing l b s = ipeek b (l sell s) {-# INLINE storing #-} -- | A version of ('Control.Lens.Setter..~') that works on 'ALens'. -- -- >>> ("hello","there") & _2 #~ "world" -- ("hello","world") ( #~ ) :: ALens s t a b -> b -> s -> t ( #~ ) l b s = ipeek b (l sell s) {-# INLINE ( #~ ) #-} -- | A version of ('Control.Lens.Setter.%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 #%~ length -- ("hello",5) ( #%~ ) :: ALens s t a b -> (a -> b) -> s -> t ( #%~ ) l f s = ipeeks f (l sell s) {-# INLINE ( #%~ ) #-} -- | A version of ('%%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!") -- (5,("hello","world!")) ( #%%~ ) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t ( #%%~ ) l f s = runPretext (l sell s) f {-# INLINE ( #%%~ ) #-} -- | A version of ('Control.Lens.Setter..=') that works on 'ALens'. ( #= ) :: MonadState s m => ALens s s a b -> b -> m () l #= f = modify (l #~ f) {-# INLINE ( #= ) #-} -- | A version of ('Control.Lens.Setter.%=') that works on 'ALens'. ( #%= ) :: MonadState s m => ALens s s a b -> (a -> b) -> m () l #%= f = modify (l #%~ f) {-# INLINE ( #%= ) #-} -- | A version of ('<%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 <#%~ length -- (5,("hello",5)) (<#%~) :: ALens s t a b -> (a -> b) -> s -> (b, t) l <#%~ f = \s -> runPretext (l sell s) $ \a -> let b = f a in (b, b) {-# INLINE (<#%~) #-} -- | A version of ('<%=') that works on 'ALens'. (<#%=) :: MonadState s m => ALens s s a b -> (a -> b) -> m b l <#%= f = l #%%= \a -> let b = f a in (b, b) {-# INLINE (<#%=) #-} -- | A version of ('%%=') that works on 'ALens'. ( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,1) l #%%= f = State.state $ \s -> runPretext (l sell s) f #else l #%%= f = do p <- State.gets (l sell) let (r, t) = runPretext p f State.put t return r #endif {-# INLINE ( #%%= ) #-} -- | A version of ('Control.Lens.Setter.<.~') that works on 'ALens'. -- -- >>> ("hello","there") & _2 <#~ "world" -- ("world",("hello","world")) (<#~) :: ALens s t a b -> b -> s -> (b, t) l <#~ b = \s -> (b, storing l b s) {-# INLINE (<#~) #-} -- | 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 return b {-# INLINE (<#=) #-} -- | There is a field for every type in the 'Void'. Very zen. -- -- >>> [] & mapped.devoid +~ 1 -- [] -- -- >>> Nothing & mapped.devoid %~ abs -- Nothing -- -- @ -- 'devoid' :: 'Lens'' 'Void' a -- @ devoid :: Over p f Void Void a b devoid _ = absurd {-# INLINE devoid #-} -- | We can always retrieve a @()@ from any type. -- -- >>> "hello"^.united -- () -- -- >>> "hello" & united .~ () -- "hello" united :: Lens' a () united f v = f () <&> \ () -> v {-# INLINE united #-} lens-3.10/src/Control/Lens/Level.hs0000644000000000000000000001113412226700613015276 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Level -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- This module provides combinators for breadth-first searching within -- arbitrary traversals. ---------------------------------------------------------------------------- module Control.Lens.Level ( Level , levels , ilevels ) where 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 import Data.Profunctor.Unsafe -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Char levelIns :: Bazaar (->) a b t -> [Level () a] levelIns = go 0 . (runAccessor #. bazaar (Accessor #. deepening ())) where go k z = k `seq` runDeepening z k $ \ xs b -> xs : if b then (go $! k + 1) z else [] {-# INLINE levelIns #-} levelOuts :: Bazaar (->) a b t -> [Level j b] -> t levelOuts bz = runFlows $ runBazaar bz $ \ _ -> Flows $ \t -> case t of One _ a : _ -> a _ -> error "levelOuts: wrong shape" {-# INLINE levelOuts #-} -- | This provides a breadth-first 'Traversal' of the individual 'levels' of any other 'Traversal' -- via iterative deepening depth-first search. The levels are returned to you in a compressed format. -- -- This can permit us to extract the 'levels' directly: -- -- >>> ["hello","world"]^..levels (traverse.traverse) -- [Zero,Zero,One () 'h',Two 0 (One () 'e') (One () 'w'),Two 0 (One () 'l') (One () 'o'),Two 0 (One () 'l') (One () 'r'),Two 0 (One () 'o') (One () 'l'),One () 'd'] -- -- But we can also traverse them in turn: -- -- >>> ["hello","world"]^..levels (traverse.traverse).traverse -- "hewlolrold" -- -- We can use this to traverse to a fixed depth in the tree of ('<*>') used in the 'Traversal': -- -- >>> ["hello","world"] & taking 4 (levels (traverse.traverse)).traverse %~ toUpper -- ["HEllo","World"] -- -- Or we can use it to traverse the first @n@ elements in found in that 'Traversal' regardless of the depth -- at which they were found. -- -- >>> ["hello","world"] & taking 4 (levels (traverse.traverse).traverse) %~ toUpper -- ["HELlo","World"] -- -- The resulting 'Traversal' of the 'levels' which is indexed by the depth of each 'Level'. -- -- >>> ["dog","cat"]^@..levels (traverse.traverse) <. traverse -- [(2,'d'),(3,'o'),(3,'c'),(4,'g'),(4,'a'),(5,'t')] -- -- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information -- in an order that violates the 'Applicative' laws. levels :: ATraversal s t a b -> IndexedTraversal Int s t (Level () a) (Level () b) levels l f s = levelOuts bz <$> traversed f (levelIns bz) where bz = l sell s {-# INLINE levels #-} ilevelIns :: Bazaar (Indexed i) a b t -> [Level i a] ilevelIns = go 0 . (runAccessor #. bazaar (Indexed $ \ i -> Accessor #. deepening i)) where go k z = k `seq` runDeepening z k $ \ xs b -> xs : if b then (go $! k + 1) z else [] {-# INLINE ilevelIns #-} ilevelOuts :: Bazaar (Indexed i) a b t -> [Level j b] -> t ilevelOuts bz = runFlows $ runBazaar bz $ Indexed $ \ _ _ -> Flows $ \t -> case t of One _ a : _ -> a _ -> error "ilevelOuts: wrong shape" {-# INLINE ilevelOuts #-} -- | This provides a breadth-first 'Traversal' of the individual levels of any other 'Traversal' -- via iterative deepening depth-first search. The levels are returned to you in a compressed format. -- -- This is similar to 'levels', but retains the index of the original 'IndexedTraversal', so you can -- access it when traversing the levels later on. -- -- >>> ["dog","cat"]^@..ilevels (traversed<.>traversed).itraversed -- [((0,0),'d'),((0,1),'o'),((1,0),'c'),((0,2),'g'),((1,1),'a'),((1,2),'t')] -- -- The resulting 'Traversal' of the levels which is indexed by the depth of each 'Level'. -- -- >>> ["dog","cat"]^@..ilevels (traversed<.>traversed)<.>itraversed -- [((2,(0,0)),'d'),((3,(0,1)),'o'),((3,(1,0)),'c'),((4,(0,2)),'g'),((4,(1,1)),'a'),((5,(1,2)),'t')] -- -- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information -- in an order that violates the 'Applicative' laws. ilevels :: AnIndexedTraversal i s t a b -> IndexedTraversal Int s t (Level i a) (Level j b) ilevels l f s = ilevelOuts bz <$> traversed f (ilevelIns bz) where bz = l sell s {-# INLINE ilevels #-} lens-3.10/src/Control/Lens/Loupe.hs0000644000000000000000000000264312226700613015320 0ustar0000000000000000------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Loupe -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- This module exports a minimalist API for working with lenses in highly -- monomorphic settings. ------------------------------------------------------------------------------- module Control.Lens.Loupe ( ALens, ALens' , cloneLens , storing , (^#) , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~) , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=) -- * Deprecated Aliases , Loupe, SimpleLoupe ) where import Control.Lens.Internal.Context import Control.Lens.Lens import Control.Lens.Type -- | This is an older alias for a type-restricted form of lens that is able to be passed around -- in containers monomorphically. -- -- Deprecated. This has since been renamed to 'ALens' for consistency. type Loupe s t a b = LensLike (Pretext (->) a b) s t a b {-# DEPRECATED Loupe "use ALens" #-} -- | @ -- type 'SimpleLoupe' = 'Simple' 'Loupe' -- @ -- -- Deprecated for two reasons. 'Loupe' is now 'ALens', and we no longer use the verbose @SimpleFoo@ naming -- convention, this has since been renamed to 'ALens'' for consistency. type SimpleLoupe s a = Loupe s s a a {-# DEPRECATED SimpleLoupe "use ALens'" #-} lens-3.10/src/Control/Lens/Operators.hs0000644000000000000000000000455212226700613016213 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Operators -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module exists for users who like to work with qualified imports -- but want access to the operators from Lens. -- -- > import qualified Control.Lens as L -- > import Control.Lens.Operators ---------------------------------------------------------------------------- module Control.Lens.Operators ( -- * General Purpose (&), (<&>), (??) -- * Getting , (^.), (^@.) -- ** Loupes , (^#) -- ** with Effects , (^!), (^@!) , (^!!), (^@!!) , (^!?), (^@!?) -- ** from Folds , (^..), (^@..) , (^?), (^@?) , (^?!), (^@?!) -- * Reviewing , ( # ) -- * Common Operators -- ** Setting , (.~) , (.=) , (<.~), (<.=) , (<<.~), (<<.=) --- *** Loupes , ( #~ ), ( #= ) , (<#~), (<#=) -- *** Just , (?~), (?=) , (~), (<>=), (<<>~), (<<>=) -- * Composing Indices , (<.>), (<.), (.>) -- * Monadic Assignment , (<~), (<<~) -- * Zippers , (:>)(), (:>>)() -- * Cons and Snoc , (<|), (|>) ) 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 {-# ANN module "HLint: ignore Use import/export shortcut" #-} lens-3.10/src/Control/Lens/Plated.hs0000644000000000000000000005461212226700613015450 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell #endif #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Plated -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- The name \"plate\" stems originally from \"boilerplate\", which was the term -- used by the \"Scrap Your Boilerplate\" papers, and later inherited by Neil -- Mitchell's \"Uniplate\". -- -- -- -- The combinators in here are designed to be compatible with and subsume the -- @uniplate@ API with the notion of a 'Traversal' replacing -- a 'Data.Data.Lens.uniplate' or 'Data.Data.Lens.biplate'. -- -- By implementing these combinators in terms of 'plate' instead of -- 'Data.Data.Lens.uniplate' additional type safety is gained, as the user is -- no longer responsible for maintaining invariants such as the number of -- children they received. -- -- Note: The @Biplate@ is /deliberately/ excluded from the API here, with the -- intention that you replace them with either explicit traversals, or by using the -- @On@ variants of the combinators below with 'Data.Data.Lens.biplate' from -- @Data.Data.Lens@. As a design, it forced the user into too many situations where -- they had to choose between correctness and ease of use, and it was brittle in the -- face of competing imports. -- -- The sensible use of these combinators makes some simple assumptions. Notably, any -- of the @On@ combinators are expecting a 'Traversal', 'Setter' or 'Fold' -- to play the role of the 'Data.Data.Lens.biplate' combinator, and so when the -- types of the contents and the container match, they should be the 'id' 'Traversal', -- 'Setter' or 'Fold'. -- -- It is often beneficial to use the combinators in this module with the combinators -- from @Data.Data.Lens@ or @GHC.Generics.Lens@ to make it easier to automatically -- derive definitions for 'plate', or to derive custom traversals. ------------------------------------------------------------------------------- module Control.Lens.Plated ( -- * Uniplate Plated(..) -- * Uniplate Combinators , children , rewrite, rewriteOf, rewriteOn, rewriteOnOf , rewriteM, rewriteMOf, rewriteMOn, rewriteMOnOf , universe, universeOf, universeOn, universeOnOf , transform, transformOf, transformOn, transformOnOf , transformM, transformMOf, transformMOn, transformMOnOf , contexts, contextsOf, contextsOn, contextsOnOf , holes, holesOn, holesOnOf , para, paraOf -- * Compos -- $compos , composOpFold -- * Parts , parts ) where import Control.Applicative import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Indexed import Control.Lens.Internal.Context import Control.Lens.Type 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 {-# ANN module "HLint: ignore Reduce duplication" #-} -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. -- -- /Example 1/: -- -- @ -- import Control.Applicative -- import Control.Lens -- import Control.Lens.Plated -- import Data.Data -- import Data.Data.Lens ('Data.Data.Lens.uniplate') -- @ -- -- @ -- data Expr -- = Val 'Int' -- | Neg Expr -- | Add Expr Expr -- deriving ('Eq','Ord','Show','Read','Data','Typeable') -- @ -- -- @ -- instance 'Plated' Expr where -- 'plate' f (Neg e) = Neg '<$>' f e -- 'plate' f (Add a b) = Add '<$>' f a '<*>' f b -- 'plate' _ a = 'pure' a -- @ -- -- /or/ -- -- @ -- instance 'Plated' Expr where -- 'plate' = 'Data.Data.Lens.uniplate' -- @ -- -- /Example 2/: -- -- @ -- import Control.Applicative -- import Control.Lens -- import Control.Lens.Plated -- import Data.Data -- import Data.Data.Lens ('Data.Data.Lens.uniplate') -- @ -- -- @ -- data Tree a -- = Bin (Tree a) (Tree a) -- | Tip a -- deriving ('Eq','Ord','Show','Read','Data','Typeable') -- @ -- -- @ -- instance 'Plated' (Tree a) where -- 'plate' f (Bin l r) = Bin '<$>' f l '<*>' f r -- 'plate' _ t = 'pure' t -- @ -- -- /or/ -- -- @ -- instance 'Data' a => 'Plated' (Tree a) where -- 'plate' = 'uniplate' -- @ -- -- Note the big distinction between these two implementations. -- -- The former will only treat children directly in this tree as descendents, -- the latter will treat trees contained in the values under the tips also -- as descendants! -- -- When in doubt, pick a 'Traversal' and just use the various @...Of@ combinators -- rather than pollute 'Plated' with orphan instances! -- -- If you want to find something unplated and non-recursive with 'Data.Data.Lens.biplate' -- use the @...OnOf@ variant with 'ignored', though those usecases are much better served -- in most cases by using the existing 'Lens' combinators! e.g. -- -- @ -- 'toListOf' 'biplate' ≡ 'universeOnOf' 'biplate' 'ignored' -- @ -- -- This same ability to explicitly pass the 'Traversal' in question is why there is no -- analogue to uniplate's @Biplate@. -- -- Moreover, since we can allow custom traversals, we implement reasonable defaults for -- polymorphic data types, that only 'Control.Traversable.traverse' into themselves, and /not/ their -- polymorphic arguments. class Plated a where -- | 'Traversal' of the immediate children of this structure. -- -- If you're using GHC 7.2 or newer and your type has a 'Data' instance, -- 'plate' will default to 'uniplate' and you can choose to not override -- it with your own definition. plate :: Traversal' a a #ifdef DEFAULT_SIGNATURES default plate :: Data a => Traversal' a a plate = uniplate #endif instance Plated [a] where plate f (x:xs) = (x:) <$> f xs plate _ [] = pure [] 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 #if !(MIN_VERSION_template_haskell(2,8,0)) instance Plated TH.Kind where plate = uniplate -- in 2.8 Kind is an alias for Type #endif instance Plated TH.Stmt where plate = uniplate instance Plated TH.Pat where plate = uniplate ------------------------------------------------------------------------------- -- Children ------------------------------------------------------------------------------- -- | Extract the immediate descendants of a 'Plated' container. -- -- @ -- 'children' ≡ 'toListOf' 'plate' -- @ children :: Plated a => a -> [a] children = toListOf plate {-# INLINE children #-} ------------------------------------------------------------------------------- -- Rewriting ------------------------------------------------------------------------------- -- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot -- be applied anywhere in the result: -- -- @ -- propRewrite r x = 'all' ('Data.Just.isNothing' '.' r) ('universe' ('rewrite' r x)) -- @ -- -- Usually 'transform' is more appropriate, but 'rewrite' can give better -- compositionality. Given two single transformations @f@ and @g@, you can -- construct @\a -> f a `mplus` g a@ which performs both rewrites until a fixed point. rewrite :: Plated a => (a -> Maybe a) -> a -> a rewrite = rewriteOf plate {-# INLINE rewrite #-} -- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot -- be applied anywhere in the result: -- -- @ -- propRewriteOf l r x = 'all' ('Data.Just.isNothing' '.' r) ('universeOf' l ('rewriteOf' l r x)) -- @ -- -- Usually 'transformOf' is more appropriate, but 'rewriteOf' can give better -- compositionality. Given two single transformations @f@ and @g@, you can -- construct @\a -> f a `mplus` g a@ which performs both rewrites until a fixed point. -- -- @ -- 'rewriteOf' :: 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> a -> a -- 'rewriteOf' :: 'Lens'' a a -> (a -> 'Maybe' a) -> a -> a -- 'rewriteOf' :: 'Traversal'' a a -> (a -> 'Maybe' a) -> a -> a -- 'rewriteOf' :: 'Setter'' a a -> (a -> 'Maybe' a) -> a -> a -- @ rewriteOf :: ASetter' a a -> (a -> Maybe a) -> a -> a rewriteOf l f = go where go = transformOf l (\x -> maybe x go (f x)) {-# INLINE rewriteOf #-} -- | Rewrite recursively over part of a larger structure. -- -- @ -- 'rewriteOn' :: 'Plated' a => 'Control.Lens.Iso.Iso'' s a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOn' :: 'Plated' a => 'Lens'' s a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOn' :: 'Plated' a => 'Traversal'' s a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOn' :: 'Plated' a => 'ASetter'' s a -> (a -> 'Maybe' a) -> s -> s -- @ rewriteOn :: Plated a => ASetter s t a a -> (a -> Maybe a) -> s -> t rewriteOn b = over b . rewrite {-# INLINE rewriteOn #-} -- | Rewrite recursively over part of a larger structure using a specified 'Setter'. -- -- @ -- 'rewriteOnOf' :: 'Plated' a => 'Control.Lens.Iso.Iso'' s a -> 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Plated' a => 'Lens'' s a -> 'Lens'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Plated' a => 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Plated' a => 'Setter'' s a -> 'Setter'' a a -> (a -> 'Maybe' a) -> s -> s -- @ rewriteOnOf :: ASetter s t a a -> ASetter' a a -> (a -> Maybe a) -> s -> t rewriteOnOf b l = over b . rewriteOf l {-# INLINE rewriteOnOf #-} -- | Rewrite by applying a monadic rule everywhere you can. Ensures that the rule cannot -- be applied anywhere in the result. rewriteM :: (Monad m, Plated a) => (a -> m (Maybe a)) -> a -> m a rewriteM = rewriteMOf plate {-# INLINE rewriteM #-} -- | Rewrite by applying a monadic rule everywhere you recursing with a user-specified 'Traversal'. -- Ensures that the rule cannot be applied anywhere in the result. rewriteMOf :: Monad m => LensLike' (WrappedMonad m) a a -> (a -> m (Maybe a)) -> a -> m a rewriteMOf l f = go where go = transformMOf l (\x -> f x >>= maybe (return x) go) {-# INLINE rewriteMOf #-} -- | Rewrite by applying a monadic rule everywhere inside of a structure located by a user-specified 'Traversal'. -- Ensures that the rule cannot be applied anywhere in the result. rewriteMOn :: (Monad m, Plated a) => LensLike (WrappedMonad m) s t a a -> (a -> m (Maybe a)) -> s -> m t rewriteMOn b = mapMOf b . rewriteM {-# INLINE rewriteMOn #-} -- | Rewrite by applying a monadic rule everywhere inside of a structure located by a user-specified 'Traversal', -- using a user-specified 'Traversal' for recursion. Ensures that the rule cannot be applied anywhere in the result. rewriteMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m (Maybe a)) -> s -> m t rewriteMOnOf b l = mapMOf b . rewriteMOf l {-# INLINE rewriteMOnOf #-} ------------------------------------------------------------------------------- -- Universe ------------------------------------------------------------------------------- -- | Retrieve all of the transitive descendants of a 'Plated' container, including itself. universe :: Plated a => a -> [a] universe = universeOf plate {-# INLINE universe #-} -- | Given a 'Fold' that knows how to locate immediate children, retrieve all of the transitive descendants of a node, including itself. -- -- @ -- 'universeOf' :: 'Fold' a a -> a -> [a] -- @ universeOf :: Getting [a] a a -> a -> [a] universeOf l = go where go a = a : foldMapOf l go a {-# INLINE universeOf #-} -- | Given a 'Fold' that knows how to find 'Plated' parts of a container retrieve them and all of their descendants, recursively. universeOn :: Plated a => Getting [a] s a -> s -> [a] universeOn b = universeOnOf b plate {-# INLINE universeOn #-} -- | Given a 'Fold' that knows how to locate immediate children, retrieve all of the transitive descendants of a node, including itself that lie -- in a region indicated by another 'Fold'. -- -- @ -- 'toListOf' l ≡ 'universeOnOf' l 'ignored' -- @ universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a] universeOnOf b = foldMapOf b . universeOf {-# INLINE universeOnOf #-} ------------------------------------------------------------------------------- -- Transformation ------------------------------------------------------------------------------- -- | Transform every element in the tree, in a bottom-up manner. -- -- For example, replacing negative literals with literals: -- -- @ -- negLits = 'transform' $ \\x -> case x of -- Neg (Lit i) -> Lit ('negate' i) -- _ -> x -- @ transform :: Plated a => (a -> a) -> a -> a transform = transformOf plate {-# INLINE transform #-} -- | Transform every element in the tree in a bottom-up manner over a region indicated by a 'Setter'. -- -- @ -- 'transformOn' :: 'Plated' a => 'Traversal'' s a -> (a -> a) -> s -> s -- 'transformOn' :: 'Plated' a => 'Setter'' s a -> (a -> a) -> s -> s -- @ transformOn :: Plated a => ASetter s t a a -> (a -> a) -> s -> t transformOn b = over b . transform {-# INLINE transformOn #-} -- | Transform every element by recursively applying a given 'Setter' in a bottom-up manner. -- -- @ -- 'transformOf' :: 'Traversal'' a a -> (a -> a) -> a -> a -- 'transformOf' :: 'Setter'' a a -> (a -> a) -> a -> a -- @ transformOf :: ASetter' a a -> (a -> a) -> a -> a transformOf l f = go where go = f . over l go {-# INLINE transformOf #-} -- | Transform every element in a region indicated by a 'Setter' by recursively applying another 'Setter' -- in a bottom-up manner. -- -- @ -- 'transformOnOf' :: 'Setter'' s a -> 'Traversal'' a a -> (a -> a) -> s -> s -- 'transformOnOf' :: 'Setter'' s a -> 'Setter'' a a -> (a -> a) -> s -> s -- @ transformOnOf :: ASetter s t a a -> ASetter' a a -> (a -> a) -> s -> t transformOnOf b l = over b . transformOf l {-# INLINE transformOnOf #-} -- | Transform every element in the tree, in a bottom-up manner, monadically. transformM :: (Monad m, Plated a) => (a -> m a) -> a -> m a transformM = transformMOf plate {-# INLINE transformM #-} -- | Transform every element in the tree in a region indicated by a supplied 'Traversal', in a bottom-up manner, monadically. -- -- @ -- 'transformMOn' :: ('Monad' m, 'Plated' a) => 'Traversal'' s a -> (a -> m a) -> s -> m s -- @ transformMOn :: (Monad m, Plated a) => LensLike (WrappedMonad m) s t a a -> (a -> m a) -> s -> m t transformMOn b = mapMOf b . transformM {-# INLINE transformMOn #-} -- | Transform every element in a tree using a user supplied 'Traversal' in a bottom-up manner with a monadic effect. -- -- @ -- 'transformMOf' :: 'Monad' m => 'Traversal'' a a -> (a -> m a) -> a -> m a -- @ transformMOf :: Monad m => LensLike' (WrappedMonad m) a a -> (a -> m a) -> a -> m a transformMOf l f = go where go t = mapMOf l go t >>= f {-# INLINE transformMOf #-} -- | Transform every element in a tree that lies in a region indicated by a supplied 'Traversal', walking with a user supplied 'Traversal' in -- a bottom-up manner with a monadic effect. -- -- @ -- 'transformMOnOf' :: 'Monad' m => 'Traversal'' s a -> 'Traversal'' a a -> (a -> m a) -> s -> m s -- @ transformMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m a) -> s -> m t transformMOnOf b l = mapMOf b . transformMOf l {-# INLINE transformMOnOf #-} ------------------------------------------------------------------------------- -- Holes and Contexts ------------------------------------------------------------------------------- -- | Return a list of all of the editable contexts for every location in the structure, recursively. -- -- @ -- propUniverse x = 'universe' x '==' 'map' 'Control.Comonad.Store.Class.pos' ('contexts' x) -- propId x = 'all' ('==' x) ['Control.Lens.Internal.Context.extract' w | w <- 'contexts' x] -- @ -- -- @ -- 'contexts' ≡ 'contextsOf' 'plate' -- @ contexts :: Plated a => a -> [Context a a a] contexts = contextsOf plate {-# INLINE contexts #-} -- | Return a list of all of the editable contexts for every location in the structure, recursively, using a user-specified 'Traversal' to walk each layer. -- -- @ -- propUniverse l x = 'universeOf' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('contextsOf' l x) -- propId l x = 'all' ('==' x) ['Control.Lens.Internal.Context.extract' w | w <- 'contextsOf' l x] -- @ -- -- @ -- 'contextsOf' :: 'Traversal'' a a -> a -> ['Context' a a a] -- @ contextsOf :: ATraversal' a a -> a -> [Context a a a] contextsOf l x = sell x : f (map context (holesOf l x)) where f xs = do Context ctx child <- xs Context cont y <- contextsOf l child return $ Context (ctx . cont) y {-# INLINE contextsOf #-} -- | Return a list of all of the editable contexts for every location in the structure in an areas indicated by a user supplied 'Traversal', recursively using 'plate'. -- -- @ -- 'contextsOn' b ≡ 'contextsOnOf' b 'plate' -- @ -- -- @ -- 'contextsOn' :: 'Plated' a => 'Traversal'' s a -> s -> ['Context' a a s] -- @ contextsOn :: Plated a => ATraversal s t a a -> s -> [Context a a t] contextsOn b = contextsOnOf b plate {-# INLINE contextsOn #-} -- | Return a list of all of the editable contexts for every location in the structure in an areas indicated by a user supplied 'Traversal', recursively using -- another user-supplied 'Traversal' to walk each layer. -- -- @ -- 'contextsOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> s -> ['Context' a a s] -- @ contextsOnOf :: ATraversal s t a a -> ATraversal' a a -> s -> [Context a a t] contextsOnOf b l = f . map context . holesOf b where f xs = do Context ctx child <- xs Context cont y <- contextsOf l child return $ Context (ctx . cont) y {-# INLINE contextsOnOf #-} -- | The one-level version of 'context'. This extracts a list of the immediate children as editable contexts. -- -- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the values, 'Control.Comonad.Store.Class.peek' at what the structure would be like with an edited result, or simply 'Control.Lens.Internal.Context.extract' the original structure. -- -- @ -- propChildren x = 'children' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holes' l x) -- propId x = 'all' ('==' x) ['Control.Lens.Internal.Context.extract' w | w <- 'holes' l x] -- @ -- -- @ -- 'holes' = 'holesOf' 'plate' -- @ holes :: Plated a => a -> [Pretext (->) a a a] holes = holesOf plate {-# INLINE holes #-} -- | An alias for 'holesOf', provided for consistency with the other combinators. -- -- @ -- 'holesOn' ≡ 'holesOf' -- @ -- -- @ -- 'holesOn' :: 'Iso'' s a -> s -> ['Pretext' (->) a a s] -- 'holesOn' :: 'Lens'' s a -> s -> ['Pretext' (->) a a s] -- 'holesOn' :: 'Traversal'' s a -> s -> ['Pretext' (->) a a s] -- '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 = holesOf {-# INLINE holesOn #-} -- | Extract one level of 'holes' from a container in a region specified by one 'Traversal', using another. -- -- @ -- 'holesOnOf' b l ≡ 'holesOf' (b '.' l) -- @ -- -- @ -- 'holesOnOf' :: 'Iso'' s a -> 'Iso'' a a -> s -> ['Pretext' (->) a a s] -- 'holesOnOf' :: 'Lens'' s a -> 'Lens'' a a -> s -> ['Pretext' (->) a a s] -- 'holesOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> s -> ['Pretext' (->) a a s] -- 'holesOnOf' :: 'Lens'' s a -> 'IndexedLens'' i a a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s] -- 'holesOnOf' :: 'Traversal'' s a -> 'IndexedTraversal'' i a a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s] -- @ holesOnOf :: Conjoined p => LensLike (Bazaar p r r) s t a b -> Overloading p (->) (Bazaar p r r) a b r r -> s -> [Pretext p r r t] holesOnOf b l = holesOf (b . l) {-# INLINE holesOnOf #-} ------------------------------------------------------------------------------- -- Paramorphisms ------------------------------------------------------------------------------- -- | Perform a fold-like computation on each value, technically a paramorphism. -- -- @ -- 'paraOf' :: 'Fold' a a -> (a -> [r] -> r) -> a -> r -- @ paraOf :: Getting (Endo [a]) a a -> (a -> [r] -> r) -> a -> r paraOf l f = go where go a = f a (go <$> toListOf l a) {-# INLINE paraOf #-} -- | Perform a fold-like computation on each value, technically a paramorphism. -- -- @ -- 'para' ≡ 'paraOf' 'plate' -- @ para :: Plated a => (a -> [r] -> r) -> a -> r para = paraOf plate {-# INLINE para #-} ------------------------------------------------------------------------------- -- Compos ------------------------------------------------------------------------------- -- $compos -- -- Provided for compatibility with Björn Bringert's @compos@ library. -- -- Note: Other operations from compos that were inherited by @uniplate@ are /not/ included -- to avoid having even more redundant names for the same operators. For comparison: -- -- @ -- 'composOpMonoid' ≡ 'foldMapOf' 'plate' -- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'to' f) -- 'composOp' ≡ 'descend' ≡ 'over' 'plate' -- 'composOpM' ≡ 'descendM' ≡ 'mapMOf' 'plate' -- 'composOpM_' ≡ 'descendM_' ≡ 'mapMOf_' 'plate' -- @ -- | Fold the immediate children of a 'Plated' container. -- -- @ -- 'composOpFold' z c f = 'foldrOf' 'plate' (c '.' f) z -- @ composOpFold :: Plated a => b -> (b -> b -> b) -> (a -> b) -> a -> b composOpFold z c f = foldrOf plate (c . f) z {-# INLINE composOpFold #-} ------------------------------------------------------------------------------- -- Parts ------------------------------------------------------------------------------- -- | The original @uniplate@ combinator, implemented in terms of 'Plated' as a 'Lens'. -- -- @ -- 'parts' ≡ 'partsOf' 'plate' -- @ -- -- The resulting 'Lens' is safer to use as it ignores 'over-application' and deals gracefully with under-application, -- but it is only a proper 'Lens' if you don't change the list 'length'! parts :: Plated a => Lens' a [a] parts = partsOf plate {-# INLINE parts #-} lens-3.10/src/Control/Lens/Prism.hs0000644000000000000000000001667212226700613015335 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Prism -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ------------------------------------------------------------------------------- module Control.Lens.Prism ( -- * Prisms Prism, Prism' , APrism, APrism' -- * Constructing Prisms , prism , prism' -- * Consuming Prisms , clonePrism , outside , aside , without , isn't -- * Common Prisms , _Left , _Right , _Just , _Nothing , _Void , only -- * Prismatic profunctors , Choice(..) ) where import Control.Applicative import Control.Lens.Combinators import Control.Lens.Internal.Prism import Control.Lens.Internal.Setter import Control.Lens.Type import Control.Monad import Data.Bifunctor import Data.Profunctor import Data.Void #ifndef SAFE import Unsafe.Coerce #else import Data.Profunctor.Unsafe #endif {-# ANN module "HLint: ignore Use camelCase" #-} -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Natural -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g ------------------------------------------------------------------------------ -- Prism Internals ------------------------------------------------------------------------------ -- | 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' = 'Simple' 'APrism' -- @ type APrism' s a = APrism s s a a -- | 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) #else runPrism k = unsafeCoerce (k (Market Mutator Right)) #endif {-# INLINE runPrism #-} -- | Clone a 'Prism' so that you can reuse the same monomorphically typed 'Prism' for different purposes. -- -- See 'Control.Lens.Lens.cloneLens' and 'Control.Lens.Traversal.cloneTraversal' for examples of why you might want to do this. clonePrism :: APrism s t a b -> Prism s t a b clonePrism k = case runPrism k of Market bt seta -> prism bt seta {-# INLINE clonePrism #-} ------------------------------------------------------------------------------ -- Prism Combinators ------------------------------------------------------------------------------ -- | Build a 'Control.Lens.Prism.Prism'. -- -- @'Either' t a@ is used instead of @'Maybe' a@ to permit the types of @s@ and @t@ to differ. -- prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt seta = dimap seta (either pure (fmap bt)) . right' {-# INLINE prism #-} -- | This is usually used to build a 'Prism'', when you have to use an operation like -- 'Data.Typeable.cast' which already returns a 'Maybe'. prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) {-# INLINE prism' #-} -- | Use a 'Prism' as a kind of first-class pattern. -- -- @'outside' :: 'Prism' s t a b -> 'Lens' (t -> r) (s -> r) (b -> r) (a -> r)@ outside :: APrism s t a b -> Lens (t -> r) (s -> r) (b -> r) (a -> r) outside k = case runPrism k of Market bt seta -> \f tr -> f (tr.bt) <&> \ar -> either tr ar . 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'. without :: APrism s t a b -> APrism u v c d -> Prism (Either s u) (Either t v) (Either a c) (Either b d) without k = case runPrism k of Market bt seta -> \ k' -> case runPrism k' of Market dv uevc -> prism (bimap bt dv) $ \su -> case su of Left s -> bimap Left Left (seta s) Right u -> bimap Right Right (uevc u) {-# INLINE without #-} -- | Check to see if this 'Prism' doesn't match. -- -- >>> isn't _Left (Right 12) -- True -- -- >>> isn't _Left (Left 12) -- False isn't :: APrism s t a b -> s -> Bool isn't k s = case runPrism k of Market _ seta -> case seta s of Left _ -> True Right _ -> False {-# INLINE isn't #-} ------------------------------------------------------------------------------ -- Common Prisms ------------------------------------------------------------------------------ -- | This 'Prism' provides a 'Traversal' for tweaking the 'Left' half of an 'Either': -- -- >>> over _Left (+1) (Left 2) -- Left 3 -- -- >>> over _Left (+1) (Right 2) -- Right 2 -- -- >>> Right 42 ^._Left :: String -- "" -- -- >>> Left "hello" ^._Left -- "hello" -- -- It also can be turned around to obtain the embedding into the 'Left' half of an 'Either': -- -- >>> _Left # 5 -- Left 5 -- -- >>> 5^.re _Left -- Left 5 _Left :: Prism (Either a c) (Either b c) a b _Left = prism Left $ either Right (Left . Right) {-# INLINE _Left #-} -- | This 'Prism' provides a 'Traversal' for tweaking the 'Right' half of an 'Either': -- -- >>> over _Right (+1) (Left 2) -- Left 2 -- -- >>> over _Right (+1) (Right 2) -- Right 3 -- -- >>> Right "hello" ^._Right -- "hello" -- -- >>> Left "hello" ^._Right :: [Double] -- [] -- -- It also can be turned around to obtain the embedding into the 'Right' half of an 'Either': -- -- >>> _Right # 5 -- Right 5 -- -- >>> 5^.re _Right -- Right 5 _Right :: Prism (Either c a) (Either c b) a b _Right = prism Right $ either (Left . Left) Right {-# INLINE _Right #-} -- | This 'Prism' provides a 'Traversal' for tweaking the target of the value of 'Just' in a 'Maybe'. -- -- >>> over _Just (+1) (Just 2) -- Just 3 -- -- Unlike 'Data.Traversable.traverse' this is a 'Prism', and so you can use it to inject as well: -- -- >>> _Just # 5 -- Just 5 -- -- >>> 5^.re _Just -- Just 5 -- -- Interestingly, -- -- @ -- m '^?' '_Just' ≡ m -- @ -- -- >>> Just x ^? _Just -- Just x -- -- >>> Nothing ^? _Just -- Nothing _Just :: Prism (Maybe a) (Maybe b) a b _Just = prism Just $ maybe (Left Nothing) Right {-# INLINE _Just #-} -- | This 'Prism' provides the 'Traversal' of a 'Nothing' in a 'Maybe'. -- -- >>> Nothing ^? _Nothing -- Just () -- -- >>> Just () ^? _Nothing -- Nothing -- -- But you can turn it around and use it to construct 'Nothing' as well: -- -- >>> _Nothing # () -- Nothing _Nothing :: Prism' (Maybe a) () _Nothing = prism' (const Nothing) $ maybe (Just ()) (const Nothing) {-# INLINE _Nothing #-} -- | 'Void' is a logically uninhabited data type. -- -- This is a 'Prism' that will always fail to match. _Void :: Prism s s a Void _Void = prism absurd Left {-# INLINE _Void #-} -- | This 'Prism' compares for exact equality with a given value. -- -- >>> only 4 # () -- 4 -- -- >>> 5 ^? only 4 -- Nothing only :: Eq a => a -> Prism' a () only a = prism' (\() -> a) $ guard . (a ==) {-# INLINE only #-} lens-3.10/src/Control/Lens/Reified.hs0000644000000000000000000000652112226700613015602 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------ -- | -- Module : Control.Lens.Reified -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ------------------------------------------------------------------------------ module Control.Lens.Reified where import Control.Lens.Type ------------------------------------------------------------------------------ -- Reifying ------------------------------------------------------------------------------ -- | 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 } -- | @ -- type 'ReifiedLens'' = 'Simple' 'ReifiedLens' -- @ type ReifiedLens' s a = ReifiedLens s s a a -- | 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 } -- | @ -- type 'ReifiedIndexedLens'' i = 'Simple' ('ReifiedIndexedLens' i) -- @ type ReifiedIndexedLens' i s a = ReifiedIndexedLens i s s a a -- | 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 } -- | @ -- type 'ReifiedIndexedTraversal'' i = 'Simple' ('ReifiedIndexedTraversal' i) -- @ type ReifiedIndexedTraversal' i s a = ReifiedIndexedTraversal i s s a a -- | 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 } -- | @ -- type 'ReifiedTraversal'' = 'Simple' 'ReifiedTraversal' -- @ type ReifiedTraversal' s a = ReifiedTraversal s s a a -- | Reify a 'Getter' so it can be stored safely in a container. newtype ReifiedGetter s a = ReifyGetter { reflectGetter :: Getter s a } -- | Reify an 'IndexedGetter' so it can be stored safely in a container. newtype ReifiedIndexedGetter i s a = ReifyIndexedGetter { reflectIndexedGetter :: IndexedGetter i s a } -- | Reify a 'Fold' so it can be stored safely in a container. newtype ReifiedFold s a = ReifyFold { reflectFold :: Fold s a } -- | 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 } -- | @ -- type 'ReifiedSetter'' = 'Simple' 'ReifiedSetter' -- @ type ReifiedSetter' s a = ReifiedSetter s s a a -- | 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 } -- | @ -- type 'ReifiedIndexedSetter'' i = 'Simple' ('ReifiedIndexedSetter' i) -- @ type ReifiedIndexedSetter' i s a = ReifiedIndexedSetter i s s a a -- | 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 } -- | @ -- type 'ReifiedIso'' = 'Simple' 'ReifiedIso' -- @ type ReifiedIso' s a = ReifiedIso s s a a -- | 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 } -- | @ -- type 'ReifiedPrism'' = 'Simple' 'ReifiedPrism' -- @ type ReifiedPrism' s a = ReifiedPrism s s a a lens-3.10/src/Control/Lens/Review.hs0000644000000000000000000001624712226700613015502 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Review -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- -- A 'Review' is a type-restricted form of a 'Prism' that can only be used for -- writing back via 're', 'review', 'reuse'. ------------------------------------------------------------------------------- module Control.Lens.Review ( -- * Reviewing Review, Review' , AReview, AReview' , unto , re , review, reviews , reuse, reuses , ( # ) , Bifunctor(bimap) , retagged , Reviewable ) where import Control.Monad.Reader as Reader import Control.Monad.State as State import Control.Lens.Getter import Control.Lens.Internal.Review import Control.Lens.Internal.Setter import Control.Lens.Type import Data.Bifunctor import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Unsafe import Data.Void -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False infixr 8 # ------------------------------------------------------------------------------ -- Review ------------------------------------------------------------------------------ -- | This is a limited form of a 'Prism' that can only be used for 're' operations. -- -- Like with a 'Getter', there are no laws to state for a 'Review'. -- -- 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 -- | 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 -- | A 'Simple' 'AReview' type AReview' t b = AReview t t b b -- | An analogue of 'to' for 'review'. -- -- @ -- 'unto' :: (b -> t) -> 'Review'' t b -- @ unto :: (Profunctor p, Bifunctor p, Functor f) => (b -> t) -> Overloaded p f s t a b unto f = first absurd . lmap absurd . rmap (fmap f) {-# INLINE unto #-} -- | Turn a 'Prism' or 'Control.Lens.Iso.Iso' around to build a 'Getter'. -- -- If you have an 'Control.Lens.Iso.Iso', 'Control.Lens.Iso.from' is a more powerful version of this function -- that will return an 'Control.Lens.Iso.Iso' instead of a mere 'Getter'. -- -- >>> 5 ^.re _Left -- Left 5 -- -- >>> 6 ^.re (_Left.unto succ) -- Left 7 -- -- @ -- 'review' ≡ 'view' '.' 're' -- 'reviews' ≡ 'views' '.' 're' -- 'reuse' ≡ 'use' '.' 're' -- 'reuses' ≡ 'uses' '.' 're' -- @ -- -- @ -- 're' :: 'Prism' s t a b -> 'Getter' b t -- '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) {-# 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. -- -- @ -- 'review' ≡ 'view' '.' 're' -- 'review' . 'unto' ≡ 'id' -- @ -- -- >>> review _Left "mustard" -- Left "mustard" -- -- >>> review (unto succ) 5 -- 6 -- -- Usually 'review' is used in the @(->)@ 'Monad' with a 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of -- it as having one of these more restricted type signatures: -- -- @ -- 'review' :: 'Iso'' s a -> a -> s -- 'review' :: 'Prism'' s a -> a -> s -- @ -- -- However, when working with a 'Monad' transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of -- these more slightly more liberal type signatures may be beneficial to think of it as having: -- -- @ -- 'review' :: 'MonadReader' a m => 'Iso'' s a -> m s -- '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) {-# INLINE review #-} -- | An infix alias for 'review'. -- -- @ -- 'unto' f # x ≡ f x -- l # x ≡ x '^.' 're' l -- @ -- -- This is commonly used when using a 'Prism' as a smart constructor. -- -- >>> _Left # 4 -- Left 4 -- -- But it can be used for any 'Prism' -- -- >>> base 16 # 123 -- "7b" -- -- @ -- (#) :: 'Iso'' s a -> a -> s -- (#) :: 'Prism'' s a -> a -> s -- (#) :: 'Review'' s a -> a -> s -- (#) :: 'Equality'' s a -> a -> s -- @ ( # ) :: AReview s t a b -> b -> t ( # ) p = runIdentity #. runReviewed #. p .# Reviewed .# 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, -- applying a function. -- -- @ -- 'reviews' ≡ 'views' '.' 're' -- 'reviews' ('unto' f) g ≡ g '.' f -- @ -- -- >>> reviews _Left isRight "mustard" -- False -- -- >>> reviews (unto succ) (*2) 3 -- 8 -- -- Usually this function is used in the @(->)@ 'Monad' with a 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of -- it as having one of these more restricted type signatures: -- -- @ -- 'reviews' :: 'Iso'' s a -> (s -> r) -> a -> r -- 'reviews' :: 'Prism'' s a -> (s -> r) -> a -> r -- @ -- -- However, when working with a 'Monad' transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of -- these more slightly more liberal type signatures may be beneficial to think of it as having: -- -- @ -- 'reviews' :: 'MonadReader' a m => 'Iso'' s a -> (s -> r) -> m r -- '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) {-# INLINE reviews #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' a value (or the current environment) through it the other way. -- -- @ -- 'reuse' ≡ 'use' '.' 're' -- 'reuse' '.' 'unto' ≡ 'gets' -- @ -- -- >>> evalState (reuse _Left) 5 -- Left 5 -- -- >>> evalState (reuse (unto succ)) 5 -- 6 -- -- @ -- 'reuse' :: 'MonadState' a m => 'Prism'' s a -> m s -- '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) {-# INLINE reuse #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' the current state through it the other way, -- applying a function. -- -- @ -- 'reuses' ≡ 'uses' '.' 're' -- 'reuses' ('unto' f) g ≡ 'gets' (g '.' f) -- @ -- -- >>> evalState (reuses _Left isLeft) (5 :: Int) -- True -- -- @ -- 'reuses' :: 'MonadState' a m => 'Prism'' s a -> (s -> r) -> m r -- '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) {-# INLINE reuses #-} lens-3.10/src/Control/Lens/Setter.hs0000644000000000000000000011415512226700613015504 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Setter -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- A @'Setter' s t a b@ is a generalization of 'fmap' from 'Functor'. It allows you to map into a -- structure and change out the contents, but it isn't strong enough to allow you to -- enumerate those contents. Starting with @'fmap' :: 'Functor' f => (a -> b) -> f a -> f b@ -- we monomorphize the type to obtain @(a -> b) -> s -> t@ and then decorate it with 'Data.Functor.Identity.Identity' to obtain: -- -- @ -- type 'Setter' s t a b = (a -> 'Data.Functor.Identity.Identity' b) -> s -> 'Data.Functor.Identity.Identity' t -- @ -- -- Every 'Traversal' is a valid 'Setter', since 'Data.Functor.Identity.Identity' is 'Applicative'. -- -- Everything you can do with a 'Functor', you can do with a 'Setter'. There -- are combinators that generalize 'fmap' and ('<$'). ---------------------------------------------------------------------------- module Control.Lens.Setter ( -- * Setters Setter, Setter' , IndexedSetter, IndexedSetter' , ASetter, ASetter' , AnIndexedSetter, AnIndexedSetter' , Setting, Setting' -- * Building Setters , sets, setting , cloneSetter , cloneIndexPreservingSetter , cloneIndexedSetter -- * Common Setters , mapped, lifted , contramapped , argument -- * Functional Combinators , over , set , (.~), (%~) , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (=), (&&=), (<.=), (?=), (>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Char -- >>> import Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> let f :: Expr -> Expr; f = Vars.f -- >>> let g :: Expr -> Expr; g = Vars.g -- >>> let h :: Expr -> Expr -> Expr; h = Vars.h -- >>> let getter :: Expr -> Expr; getter = fun "getter" -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> :set -XNoOverloadedStrings infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, =, ||=, %=, <.=, ?=, Mutator b) -> s -> Mutator t -- | This is a useful alias for use when consuming a 'Setter''. -- -- Most user code will never have to use this type. -- -- @ -- type 'ASetter'' = 'Simple' 'ASetter' -- @ type ASetter' s a = ASetter s s a a -- | Running an 'IndexedSetter' instantiates it to a concrete type. -- -- 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 = 'Simple' ('AnIndexedSetter' i) -- @ type AnIndexedSetter' i s a = AnIndexedSetter i s s a a -- | 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 -- | 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 a = Setting p s s a a ----------------------------------------------------------------------------- -- Setters ----------------------------------------------------------------------------- -- | This 'Setter' can be used to map over all of the values in a 'Functor'. -- -- @ -- 'fmap' ≡ 'over' 'mapped' -- 'Data.Traversable.fmapDefault' ≡ 'over' 'Data.Traversable.traverse' -- ('<$') ≡ 'set' 'mapped' -- @ -- -- >>> over mapped f [a,b,c] -- [f a,f b,f c] -- -- >>> over mapped (+1) [1,2,3] -- [2,3,4] -- -- >>> set mapped x [a,b,c] -- [x,x,x] -- -- >>> [[a,b],[c]] & mapped.mapped +~ x -- [[a + x,b + x],[c + x]] -- -- >>> over (mapped._2) length [("hello","world"),("leaders","!!!")] -- [("hello",5),("leaders",3)] -- -- @ -- 'mapped' :: 'Functor' f => 'Setter' (f a) (f b) a b -- @ -- -- If you want an 'IndexPreservingSetter' use @'setting' 'fmap'@. mapped :: Functor f => Setter (f a) (f b) a b mapped = sets fmap {-# INLINE mapped #-} -- | This 'setter' can be used to modify all of the values in a 'Monad'. -- -- You sometimes have to use this rather than 'mapped' -- due to -- temporary insanity 'Functor' is not a superclass of 'Monad'. -- -- @ -- 'liftM' ≡ 'over' 'lifted' -- @ -- -- >>> over lifted f [a,b,c] -- [f a,f b,f c] -- -- >>> set lifted b (Just a) -- Just b -- -- If you want an 'IndexPreservingSetter' use @'setting' 'liftM'@. lifted :: Monad m => Setter (m a) (m b) a b lifted = sets liftM {-# INLINE lifted #-} -- | This 'Setter' can be used to map over all of the inputs to a 'Contravariant'. -- -- @ -- 'contramap' ≡ 'over' 'contramapped' -- @ -- -- >>> getPredicate (over contramapped (*2) (Predicate even)) 5 -- True -- -- >>> getOp (over contramapped (*5) (Op show)) 100 -- "500" -- -- >>> Prelude.map ($ 1) $ over (mapped . wrapping Op . contramapped) (*12) [(*2),(+1),(^3)] -- [24,13,1728] -- contramapped :: Contravariant f => Setter (f b) (f a) a b contramapped = sets contramap {-# INLINE contramapped #-} -- | This 'Setter' can be used to map over the input of a 'Profunctor'. -- -- The most common 'Profunctor' to use this with is @(->)@. -- -- >>> (argument %~ f) g x -- g (f x) -- -- >>> (argument %~ show) length [1,2,3] -- 7 -- -- >>> (argument %~ f) h x y -- h (f x) y -- -- Map over the argument of the result of a function -- i.e., its second -- argument: -- -- >>> (mapped.argument %~ f) h x y -- h x (f y) -- -- @ -- 'argument' :: 'Setter' (b -> r) (a -> r) a b -- @ argument :: Profunctor p => Setter (p b r) (p a r) a b argument = sets lmap {-# INLINE argument #-} -- | Build an index-preserving 'Setter' from a map-like function. -- -- Your supplied function @f@ is required to satisfy: -- -- @ -- f 'id' ≡ 'id' -- f g '.' f h ≡ f (g '.' h) -- @ -- -- Equational reasoning: -- -- @ -- 'setting' '.' 'over' ≡ 'id' -- 'over' '.' 'setting' ≡ 'id' -- @ -- -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. -- -- @ -- 'setting' :: ((a -> b) -> s -> t) -> 'Setter' s t a b -- @ setting :: ((a -> b) -> s -> t) -> IndexPreservingSetter s t a b setting l pafb = cotabulate $ \ws -> pure $ l (\a -> untainted (corep pafb (a <$ ws))) (extract ws) {-# INLINE setting #-} -- | Build a 'Setter', 'IndexedSetter' or 'IndexPreservingSetter' depending on your choice of 'Profunctor'. -- -- @ -- '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 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) {-# 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) {-# 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))) {-# INLINE cloneIndexedSetter #-} ----------------------------------------------------------------------------- -- Using Setters ----------------------------------------------------------------------------- -- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal' -- with a function. -- -- @ -- 'fmap' ≡ 'over' 'mapped' -- 'Data.Traversable.fmapDefault' ≡ 'over' 'Data.Traversable.traverse' -- 'sets' '.' 'over' ≡ 'id' -- 'over' '.' 'sets' ≡ 'id' -- @ -- -- Given any valid 'Setter' @l@, you can also rely on the law: -- -- @ -- 'over' l f '.' 'over' l g = 'over' l (f '.' g) -- @ -- -- /e.g./ -- -- >>> over mapped f (over mapped g [a,b,c]) == over mapped (f . g) [a,b,c] -- True -- -- Another way to view 'over' is to say that it transforms a 'Setter' into a -- \"semantic editor combinator\". -- -- >>> over mapped f (Just a) -- Just (f a) -- -- >>> over mapped (*10) [1,2,3] -- [10,20,30] -- -- >>> over _1 f (a,b) -- (f a,b) -- -- >>> over _1 show (10,20) -- ("10",20) -- -- @ -- 'over' :: 'Setter' s t a b -> (a -> b) -> s -> t -- '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) {-# INLINE over #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' -- or 'Traversal' with a constant value. -- -- @ -- ('<$') ≡ 'set' 'mapped' -- @ -- -- >>> set _2 "hello" (1,()) -- (1,"hello") -- -- >>> set mapped () [1,2,3,4] -- [(),(),(),()] -- -- Note: Attempting to 'set' a 'Fold' or 'Getter' will fail at compile time with an -- relatively nice error message. -- -- @ -- 'set' :: 'Setter' s t a b -> b -> s -> t -- 'set' :: 'Iso' s t a b -> b -> s -> t -- 'set' :: 'Lens' s t a b -> b -> s -> t -- '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) {-# INLINE set #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter'' -- or 'Traversal' with a constant value, without changing its type. -- -- This is a type restricted version of 'set', which retains the type of the original. -- -- >>> set' mapped x [a,b,c,d] -- [x,x,x,x] -- -- >>> set' _2 "hello" (1,"world") -- (1,"hello") -- -- >>> set' mapped 0 [1,2,3,4] -- [0,0,0,0] -- -- Note: Attempting to adjust 'set'' a 'Fold' or 'Getter' will fail at compile time with an -- relatively nice error message. -- -- @ -- 'set'' :: 'Setter'' s a -> a -> s -> s -- 'set'' :: 'Iso'' s a -> a -> s -> s -- 'set'' :: 'Lens'' s a -> a -> s -> s -- 'set'' :: 'Traversal'' s a -> a -> s -> s -- @ set' :: ASetter' s a -> a -> s -> s set' l b = runMutator #. l (\_ -> Mutator b) {-# INLINE set' #-} -- | Modifies the target of a 'Lens' or all of the targets of a 'Setter' or -- 'Traversal' with a user supplied function. -- -- This is an infix version of 'over'. -- -- @ -- 'fmap' f ≡ 'mapped' '%~' f -- 'Data.Traversable.fmapDefault' f ≡ 'Data.Traversable.traverse' '%~' f -- @ -- -- >>> (a,b,c) & _3 %~ f -- (a,b,f c) -- -- >>> (a,b) & both %~ f -- (f a,f b) -- -- >>> _2 %~ length $ (1,"hello") -- (1,5) -- -- >>> traverse %~ f $ [a,b,c] -- [f a,f b,f c] -- -- >>> traverse %~ even $ [1,2,3] -- [False,True,False] -- -- >>> traverse.traverse %~ length $ [["hello","world"],["!!!"]] -- [[5,5],[3]] -- -- @ -- ('%~') :: 'Setter' s t a b -> (a -> b) -> s -> t -- ('%~') :: 'Iso' s t a b -> (a -> b) -> s -> t -- ('%~') :: 'Lens' s t a b -> (a -> b) -> s -> t -- ('%~') :: 'Traversal' s t a b -> (a -> b) -> s -> t -- @ (%~) :: Profunctor p => Setting p s t a b -> p a b -> s -> t (%~) = over {-# INLINE (%~) #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' -- or 'Traversal' with a constant value. -- -- This is an infix version of 'set', provided for consistency with ('.='). -- -- @ -- f '<$' a ≡ 'mapped' '.~' f '$' a -- @ -- -- >>> (a,b,c,d) & _4 .~ e -- (a,b,c,e) -- -- >>> (42,"world") & _1 .~ "hello" -- ("hello","world") -- -- >>> (a,b) & both .~ c -- (c,c) -- -- @ -- ('.~') :: 'Setter' s t a b -> b -> s -> t -- ('.~') :: 'Iso' s t a b -> b -> s -> t -- ('.~') :: 'Lens' s t a b -> b -> s -> t -- ('.~') :: 'Traversal' s t a b -> b -> s -> t -- @ (.~) :: ASetter s t a b -> b -> s -> t (.~) = set {-# INLINE (.~) #-} -- | Set the target of a 'Lens', 'Traversal' or 'Setter' to 'Just' a value. -- -- @ -- l '?~' t ≡ 'set' l ('Just' t) -- @ -- -- >>> Nothing & id ?~ a -- Just a -- -- >>> Map.empty & at 3 ?~ x -- fromList [(3,x)] -- -- @ -- ('?~') :: 'Setter' s t a ('Maybe' b) -> b -> s -> t -- ('?~') :: 'Iso' s t a ('Maybe' b) -> b -> s -> t -- ('?~') :: 'Lens' s t a ('Maybe' b) -> b -> s -> t -- ('?~') :: 'Traversal' s t a ('Maybe' b) -> b -> s -> t -- @ (?~) :: ASetter s t a (Maybe b) -> b -> s -> t l ?~ b = set l (Just b) {-# INLINE (?~) #-} -- | Set with pass-through. -- -- This is mostly present for consistency, but may be useful for for chaining assignments. -- -- If you do not need a copy of the intermediate result, then using @l '.~' t@ directly is a good idea. -- -- >>> (a,b) & _1 <.~ c -- (c,(c,b)) -- -- >>> ("good","morning","vietnam") & _3 <.~ "world" -- ("world",("good","morning","world")) -- -- >>> (42,Map.fromList [("goodnight","gracie")]) & _2.at "hello" <.~ Just "world" -- (Just "world",(42,fromList [("goodnight","gracie"),("hello","world")])) -- -- @ -- ('<.~') :: 'Setter' s t a b -> b -> s -> (b, t) -- ('<.~') :: 'Iso' s t a b -> b -> s -> (b, t) -- ('<.~') :: 'Lens' s t a b -> b -> s -> (b, t) -- ('<.~') :: 'Traversal' s t a b -> b -> s -> (b, t) -- @ (<.~) :: ASetter s t a b -> b -> s -> (b, t) l <.~ b = \s -> (b, set l b s) {-# INLINE (<.~) #-} -- | Set to 'Just' a value with pass-through. -- -- This is mostly present for consistency, but may be useful for for chaining assignments. -- -- If you do not need a copy of the intermediate result, then using @l '?~' d@ directly is a good idea. -- -- >>> import Data.Map as Map -- >>> _2.at "hello" b -> s -> (b, t) -- (' b -> s -> (b, t) -- (' b -> s -> (b, t) -- (' b -> s -> (b, t) -- @ ( b -> s -> (b, t) l (b, set l (Just b) s) {-# INLINE (>> (a,b) & _1 +~ c -- (a + c,b) -- -- >>> (a,b) & both +~ c -- (a + c,b + c) -- -- >>> (1,2) & _2 +~ 1 -- (1,3) -- -- >>> [(a,b),(c,d)] & traverse.both +~ e -- [(a + e,b + e),(c + e,d + e)] -- -- @ -- ('+~') :: 'Num' a => 'Setter'' s a -> a -> s -> s -- ('+~') :: 'Num' a => 'Iso'' s a -> a -> s -> s -- ('+~') :: 'Num' a => 'Lens'' s a -> a -> s -> s -- ('+~') :: 'Num' a => 'Traversal'' s a -> a -> s -> s -- @ (+~) :: Num a => ASetter s t a a -> a -> s -> t l +~ n = over l (+ n) {-# INLINE (+~) #-} -- | Multiply the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal'. -- -- >>> (a,b) & _1 *~ c -- (a * c,b) -- -- >>> (a,b) & both *~ c -- (a * c,b * c) -- -- >>> (1,2) & _2 *~ 4 -- (1,8) -- -- >>> Just 24 & mapped *~ 2 -- Just 48 -- -- @ -- ('*~') :: 'Num' a => 'Setter'' s a -> a -> s -> s -- ('*~') :: 'Num' a => 'Iso'' s a -> a -> s -> s -- ('*~') :: 'Num' a => 'Lens'' s a -> a -> s -> s -- ('*~') :: 'Num' a => 'Traversal'' s a -> a -> s -> s -- @ (*~) :: Num a => ASetter s t a a -> a -> s -> t l *~ n = over l (* n) {-# INLINE (*~) #-} -- | Decrement the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal'. -- -- >>> (a,b) & _1 -~ c -- (a - c,b) -- -- >>> (a,b) & both -~ c -- (a - c,b - c) -- -- >>> _1 -~ 2 $ (1,2) -- (-1,2) -- -- >>> mapped.mapped -~ 1 $ [[4,5],[6,7]] -- [[3,4],[5,6]] -- -- @ -- ('-~') :: 'Num' a => 'Setter'' s a -> a -> s -> s -- ('-~') :: 'Num' a => 'Iso'' s a -> a -> s -> s -- ('-~') :: 'Num' a => 'Lens'' s a -> a -> s -> s -- ('-~') :: 'Num' a => 'Traversal'' s a -> a -> s -> s -- @ (-~) :: Num a => ASetter s t a a -> a -> s -> t l -~ n = over l (subtract n) {-# INLINE (-~) #-} -- | Divide the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal'. -- -- >>> (a,b) & _1 //~ c -- (a / c,b) -- -- >>> (a,b) & both //~ c -- (a / c,b / c) -- -- >>> ("Hawaii",10) & _2 //~ 2 -- ("Hawaii",5.0) -- -- @ -- ('//~') :: 'Fractional' a => 'Setter'' s a -> a -> s -> s -- ('//~') :: 'Fractional' a => 'Iso'' s a -> a -> s -> s -- ('//~') :: 'Fractional' a => 'Lens'' s a -> a -> s -> s -- ('//~') :: 'Fractional' a => 'Traversal'' s a -> a -> s -> s -- @ (//~) :: Fractional a => ASetter s t a a -> a -> s -> t l //~ n = over l (/ n) {-# INLINE (//~) #-} -- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to a non-negative integral power. -- -- >>> (1,3) & _2 ^~ 2 -- (1,9) -- -- @ -- ('^~') :: ('Num' a, 'Integral' e) => 'Setter'' s a -> e -> s -> s -- ('^~') :: ('Num' a, 'Integral' e) => 'Iso'' s a -> e -> s -> s -- ('^~') :: ('Num' a, 'Integral' e) => 'Lens'' s a -> e -> s -> s -- ('^~') :: ('Num' a, 'Integral' e) => 'Traversal'' s a -> e -> s -> s -- @ (^~) :: (Num a, Integral e) => ASetter s t a a -> e -> s -> t l ^~ n = over l (^ n) {-# INLINE (^~) #-} -- | Raise the target(s) of a fractionally valued 'Lens', 'Setter' or 'Traversal' to an integral power. -- -- >>> (1,2) & _2 ^^~ (-1) -- (1,0.5) -- -- @ -- ('^^~') :: ('Fractional' a, 'Integral' e) => 'Setter'' s a -> e -> s -> s -- ('^^~') :: ('Fractional' a, 'Integral' e) => 'Iso'' s a -> e -> s -> s -- ('^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> s -- ('^^~') :: ('Fractional' a, 'Integral' e) => 'Traversal'' s a -> e -> s -> s -- @ -- (^^~) :: (Fractional a, Integral e) => ASetter s t a a -> e -> s -> t l ^^~ n = over l (^^ n) {-# INLINE (^^~) #-} -- | Raise the target(s) of a floating-point valued 'Lens', 'Setter' or 'Traversal' to an arbitrary power. -- -- >>> (a,b) & _1 **~ c -- (a**c,b) -- -- >>> (a,b) & both **~ c -- (a**c,b**c) -- -- >>> _2 **~ pi $ (1,3) -- (1,31.54428070019754) -- -- @ -- ('**~') :: 'Floating' a => 'Setter'' s a -> a -> s -> s -- ('**~') :: 'Floating' a => 'Iso'' s a -> a -> s -> s -- ('**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> s -- ('**~') :: 'Floating' a => 'Traversal'' s a -> a -> s -> s -- @ (**~) :: Floating a => ASetter s t a a -> a -> s -> t l **~ n = over l (** n) {-# INLINE (**~) #-} -- | Logically '||' the target(s) of a 'Bool'-valued 'Lens' or 'Setter'. -- -- >>> both ||~ True $ (False,True) -- (True,True) -- -- >>> both ||~ False $ (False,True) -- (False,True) -- -- @ -- ('||~') :: 'Setter'' s 'Bool' -> 'Bool' -> s -> s -- ('||~') :: 'Iso'' s 'Bool' -> 'Bool' -> s -> s -- ('||~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> s -- ('||~') :: 'Traversal'' s 'Bool' -> 'Bool' -> s -> s -- @ (||~):: ASetter s t Bool Bool -> Bool -> s -> t l ||~ n = over l (|| n) {-# INLINE (||~) #-} -- | Logically '&&' the target(s) of a 'Bool'-valued 'Lens' or 'Setter'. -- -- >>> both &&~ True $ (False, True) -- (False,True) -- -- >>> both &&~ False $ (False, True) -- (False,False) -- -- @ -- ('&&~') :: 'Setter'' s 'Bool' -> 'Bool' -> s -> s -- ('&&~') :: 'Iso'' s 'Bool' -> 'Bool' -> s -> s -- ('&&~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> s -- ('&&~') :: 'Traversal'' s 'Bool' -> 'Bool' -> s -> s -- @ (&&~) :: ASetter s t Bool Bool -> Bool -> s -> t l &&~ n = over l (&& n) {-# INLINE (&&~) #-} ------------------------------------------------------------------------------ -- Using Setters with State ------------------------------------------------------------------------------ -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' or 'Traversal' in our monadic -- state with a new value, irrespective of the old. -- -- This is an alias for ('.='). -- -- >>> execState (do assign _1 c; assign _2 d) (a,b) -- (c,d) -- -- >>> execState (both .= c) (a,b) -- (c,c) -- -- @ -- 'assign' :: 'MonadState' s m => 'Iso'' s a -> a -> m () -- 'assign' :: 'MonadState' s m => 'Lens'' s a -> a -> m () -- 'assign' :: 'MonadState' s m => 'Traversal'' s a -> a -> m () -- 'assign' :: 'MonadState' s m => 'Setter'' s a -> a -> m () -- @ assign :: MonadState s m => ASetter s s a b -> b -> m () assign l b = State.modify (set l b) {-# INLINE assign #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' -- or 'Traversal' in our monadic state with a new value, irrespective of the -- old. -- -- This is an infix version of 'assign'. -- -- >>> execState (do _1 .= c; _2 .= d) (a,b) -- (c,d) -- -- >>> execState (both .= c) (a,b) -- (c,c) -- -- @ -- ('.=') :: 'MonadState' s m => 'Iso'' s a -> a -> m () -- ('.=') :: 'MonadState' s m => 'Lens'' s a -> a -> m () -- ('.=') :: 'MonadState' s m => 'Traversal'' s a -> a -> m () -- ('.=') :: 'MonadState' s m => 'Setter'' s a -> a -> m () -- @ -- -- "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 (.=) #-} -- | Map over the target of a 'Lens' or all of the targets of a 'Setter' or 'Traversal' in our monadic state. -- -- >>> execState (do _1 %= f;_2 %= g) (a,b) -- (f a,g b) -- -- >>> execState (do both %= f) (a,b) -- (f a,f b) -- -- @ -- ('%=') :: 'MonadState' s m => 'Iso'' s a -> (a -> a) -> m () -- ('%=') :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m () -- ('%=') :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m () -- ('%=') :: 'MonadState' s m => 'Setter'' s a -> (a -> a) -> m () -- @ -- -- @ -- ('%=') :: 'MonadState' s m => 'ASetter' s s a b -> (a -> b) -> m () -- @ (%=) :: (Profunctor p, MonadState s m) => Setting p s s a b -> p a b -> m () l %= f = State.modify (l %~ f) {-# INLINE (%=) #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' or 'Traversal' in our monadic -- state with 'Just' a new value, irrespective of the old. -- -- >>> execState (do at 1 ?= a; at 2 ?= b) Map.empty -- fromList [(1,a),(2,b)] -- -- >>> execState (do _1 ?= b; _2 ?= c) (Just a, Nothing) -- (Just b,Just c) -- -- @ -- ('?=') :: 'MonadState' s m => 'Iso'' s ('Maybe' a) -> a -> m () -- ('?=') :: 'MonadState' s m => 'Lens'' s ('Maybe' a) -> a -> m () -- ('?=') :: 'MonadState' s m => 'Traversal'' s ('Maybe' a) -> a -> m () -- ('?=') :: 'MonadState' s m => 'Setter'' s ('Maybe' a) -> a -> m () -- @ (?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () l ?= b = State.modify (l ?~ b) {-# INLINE (?=) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by adding a value. -- -- Example: -- -- @ -- 'fresh' :: 'MonadState' 'Int' m => m 'Int' -- 'fresh' = do -- 'id' '+=' 1 -- 'Control.Lens.Getter.use' 'id' -- @ -- -- >>> execState (do _1 += c; _2 += d) (a,b) -- (a + c,b + d) -- -- >>> execState (do _1.at 1.non 0 += 10) (Map.fromList [(2,100)],"hello") -- (fromList [(1,10),(2,100)],"hello") -- -- @ -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Setter'' s a -> a -> m () -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m () -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m () -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Traversal'' s a -> a -> m () -- @ (+=) :: (MonadState s m, Num a) => ASetter' s a -> a -> m () l += b = State.modify (l +~ b) {-# INLINE (+=) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by subtracting a value. -- -- >>> execState (do _1 -= c; _2 -= d) (a,b) -- (a - c,b - d) -- -- @ -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Setter'' s a -> a -> m () -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m () -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m () -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Traversal'' s a -> a -> m () -- @ (-=) :: (MonadState s m, Num a) => ASetter' s a -> a -> m () l -= b = State.modify (l -~ b) {-# INLINE (-=) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by multiplying by value. -- -- >>> execState (do _1 *= c; _2 *= d) (a,b) -- (a * c,b * d) -- -- @ -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Setter'' s a -> a -> m () -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m () -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m () -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Traversal'' s a -> a -> m () -- @ (*=) :: (MonadState s m, Num a) => ASetter' s a -> a -> m () l *= b = State.modify (l *~ b) {-# INLINE (*=) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by dividing by a value. -- -- >>> execState (do _1 //= c; _2 //= d) (a,b) -- (a / c,b / d) -- -- @ -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Setter'' s a -> a -> m () -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Iso'' s a -> a -> m () -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Lens'' s a -> a -> m () -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Traversal'' s a -> a -> m () -- @ (//=) :: (MonadState s m, Fractional a) => ASetter' s a -> a -> m () l //= a = State.modify (l //~ a) {-# INLINE (//=) #-} -- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to a non-negative integral power. -- -- @ -- ('^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Setter'' s a -> e -> m () -- ('^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Iso'' s a -> e -> m () -- ('^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Lens'' s a -> e -> m () -- ('^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Traversal'' s a -> e -> m () -- @ (^=) :: (MonadState s m, Num a, Integral e) => ASetter' s a -> e -> m () l ^= e = State.modify (l ^~ e) {-# INLINE (^=) #-} -- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to an integral power. -- -- @ -- ('^^=') :: ('MonadState' s m, 'Fractional' a, 'Integral' e) => 'Setter'' s a -> e -> m () -- ('^^=') :: ('MonadState' s m, 'Fractional' a, 'Integral' e) => 'Iso'' s a -> e -> m () -- ('^^=') :: ('MonadState' s m, 'Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> m () -- ('^^=') :: ('MonadState' s m, 'Fractional' a, 'Integral' e) => 'Traversal'' s a -> e -> m () -- @ (^^=) :: (MonadState s m, Fractional a, Integral e) => ASetter' s a -> e -> m () l ^^= e = State.modify (l ^^~ e) {-# INLINE (^^=) #-} -- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to an arbitrary power -- -- >>> execState (do _1 **= c; _2 **= d) (a,b) -- (a**c,b**d) -- -- @ -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Setter'' s a -> a -> m () -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Iso'' s a -> a -> m () -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Lens'' s a -> a -> m () -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Traversal'' s a -> a -> m () -- @ (**=) :: (MonadState s m, Floating a) => ASetter' s a -> a -> m () l **= a = State.modify (l **~ a) {-# INLINE (**=) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by taking their logical '&&' with a value. -- -- >>> execState (do _1 &&= True; _2 &&= False; _3 &&= True; _4 &&= False) (True,True,False,False) -- (True,False,False,False) -- -- @ -- ('&&=') :: 'MonadState' s m => 'Setter'' s 'Bool' -> 'Bool' -> m () -- ('&&=') :: 'MonadState' s m => 'Iso'' s 'Bool' -> 'Bool' -> m () -- ('&&=') :: 'MonadState' s m => 'Lens'' s 'Bool' -> 'Bool' -> m () -- ('&&=') :: 'MonadState' s m => 'Traversal'' s 'Bool' -> 'Bool' -> m () -- @ (&&=):: MonadState s m => ASetter' s Bool -> Bool -> m () l &&= b = State.modify (l &&~ b) {-# INLINE (&&=) #-} -- | Modify the target(s) of a 'Lens'', 'Iso, 'Setter' or 'Traversal' by taking their logical '||' with a value. -- -- >>> execState (do _1 ||= True; _2 ||= False; _3 ||= True; _4 ||= False) (True,True,False,False) -- (True,True,True,False) -- -- @ -- ('||=') :: 'MonadState' s m => 'Setter'' s 'Bool' -> 'Bool' -> m () -- ('||=') :: 'MonadState' s m => 'Iso'' s 'Bool' -> 'Bool' -> m () -- ('||=') :: 'MonadState' s m => 'Lens'' s 'Bool' -> 'Bool' -> m () -- ('||=') :: 'MonadState' s m => 'Traversal'' s 'Bool' -> 'Bool' -> m () -- @ (||=) :: MonadState s m => ASetter' s Bool -> Bool -> m () l ||= b = State.modify (l ||~ b) {-# INLINE (||=) #-} -- | Run a monadic action, and set all of the targets of a 'Lens', 'Setter' or 'Traversal' to its result. -- -- @ -- ('<~') :: 'MonadState' s m => 'Iso' s s a b -> m b -> m () -- ('<~') :: 'MonadState' s m => 'Lens' s s a b -> m b -> m () -- ('<~') :: 'MonadState' s m => 'Traversal' s s a b -> m b -> m () -- ('<~') :: 'MonadState' s m => 'Setter' s s a b -> m b -> m () -- @ -- -- As a reasonable mnemonic, this lets you store the result of a monadic action in a 'Lens' rather than -- in a local variable. -- -- @ -- do foo <- bar -- ... -- @ -- -- will store the result in a variable, while -- -- @ -- do foo '<~' bar -- ... -- @ -- -- will store the result in a 'Lens', 'Setter', or 'Traversal'. (<~) :: MonadState s m => ASetter s s a b -> m b -> m () l <~ mb = mb >>= (l .=) {-# INLINE (<~) #-} -- | Set with pass-through -- -- This is useful for chaining assignment without round-tripping through your 'Monad' stack. -- -- @ -- do x <- 'Control.Lens.Tuple._2' '<.=' ninety_nine_bottles_of_beer_on_the_wall -- @ -- -- If you do not need a copy of the intermediate result, then using @l '.=' d@ will avoid unused binding warnings. -- -- @ -- ('<.=') :: 'MonadState' s m => 'Setter' s s a b -> b -> m b -- ('<.=') :: 'MonadState' s m => 'Iso' s s a b -> b -> m b -- ('<.=') :: 'MonadState' s m => 'Lens' s s a b -> b -> m b -- ('<.=') :: 'MonadState' s m => 'Traversal' s s a b -> b -> m b -- @ (<.=) :: MonadState s m => ASetter s s a b -> b -> m b l <.= b = do l .= b return b {-# INLINE (<.=) #-} -- | Set 'Just' a value with pass-through -- -- This is useful for chaining assignment without round-tripping through your 'Monad' stack. -- -- @ -- do x <- 'Control.Lens.At.at' "foo" ' 'Setter' s s a ('Maybe' b) -> b -> m b -- (' 'Iso' s s a ('Maybe' b) -> b -> m b -- (' 'Lens' s s a ('Maybe' b) -> b -> m b -- (' 'Traversal' s s a ('Maybe' b) -> b -> m b -- @ ( ASetter s s a (Maybe b) -> b -> m b l >> (Sum a,b) & _1 <>~ Sum c -- (Sum {getSum = a + c},b) -- -- >>> (Sum a,Sum b) & both <>~ Sum c -- (Sum {getSum = a + c},Sum {getSum = b + c}) -- -- >>> both <>~ "!!!" $ ("hello","world") -- ("hello!!!","world!!!") -- -- @ -- ('<>~') :: 'Monoid' a => 'Setter' s t a a -> a -> s -> t -- ('<>~') :: 'Monoid' a => 'Iso' s t a a -> a -> s -> t -- ('<>~') :: 'Monoid' a => 'Lens' s t a a -> a -> s -> t -- ('<>~') :: 'Monoid' a => 'Traversal' s t a a -> a -> s -> t -- @ (<>~) :: Monoid a => ASetter s t a a -> a -> s -> t l <>~ n = over l (`mappend` n) {-# INLINE (<>~) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value. -- -- >>> execState (do _1 <>= Sum c; _2 <>= Product d) (Sum a,Product b) -- (Sum {getSum = a + c},Product {getProduct = b * d}) -- -- >>> execState (both <>= "!!!") ("hello","world") -- ("hello!!!","world!!!") -- -- @ -- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Setter'' s a -> a -> m () -- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Iso'' s a -> a -> m () -- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Lens'' s a -> a -> m () -- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Traversal'' s a -> a -> m () -- @ (<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () l <>= a = State.modify (l <>~ a) {-# INLINE (<>=) #-} ----------------------------------------------------------------------------- -- Writer Operations ---------------------------------------------------------------------------- -- | Write to a fragment of a larger 'Writer' format. scribe :: (MonadWriter t m, Monoid s) => ASetter s t a b -> b -> m () scribe l b = tell (set l b mempty) {-# INLINE scribe #-} -- | This is a generalization of 'pass' that alows you to modify just a -- portion of the resulting 'MonadWriter'. passing :: MonadWriter w m => Setter w w u v -> m (a, u -> v) -> m a passing l m = pass $ do (a, uv) <- m return (a, over l uv) {-# INLINE passing #-} -- | This is a generalization of 'pass' that alows you to modify just a -- portion of the resulting 'MonadWriter' with access to the index of an -- 'IndexedSetter'. ipassing :: MonadWriter w m => IndexedSetter i w w u v -> m (a, i -> u -> v) -> m a ipassing l m = pass $ do (a, uv) <- m return (a, iover l uv) {-# INLINE ipassing #-} -- | This is a generalization of 'censor' that alows you to 'censor' just a -- portion of the resulting 'MonadWriter'. censoring :: MonadWriter w m => Setter w w u v -> (u -> v) -> m a -> m a censoring l uv = censor (over l uv) {-# INLINE censoring #-} -- | This is a generalization of 'censor' that alows you to 'censor' just a -- portion of the resulting 'MonadWriter', with access to the index of an -- 'IndexedSetter'. icensoring :: MonadWriter w m => IndexedSetter i w w u v -> (i -> u -> v) -> m a -> m a icensoring l uv = censor (iover l uv) {-# INLINE icensoring #-} ----------------------------------------------------------------------------- -- Indexed Setters ---------------------------------------------------------------------------- -- | Map with index. This is an alias for 'imapOf'. -- -- When you do not need access to the index, then 'over' is more liberal in what it can accept. -- -- @ -- 'over' l ≡ 'iover' l '.' 'const' -- 'iover' l ≡ 'over' l '.' 'Indexed' -- @ -- -- @ -- 'iover' :: 'IndexedSetter' i s t a b -> (i -> a -> b) -> s -> t -- 'iover' :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- 'iover' :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ iover :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t iover l = over l .# Indexed {-# INLINE iover #-} -- | Build an 'IndexedSetter' from an 'Control.Lens.Indexed.imap'-like function. -- -- Your supplied function @f@ is required to satisfy: -- -- @ -- f 'id' ≡ 'id' -- f g '.' f h ≡ f (g '.' h) -- @ -- -- Equational reasoning: -- -- @ -- 'isets' '.' 'iover' ≡ 'id' -- 'iover' '.' 'isets' ≡ 'id' -- @ -- -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b isets f = sets (f . indexed) {-# INLINE isets #-} -- | Adjust every target of an 'IndexedSetter', 'IndexedLens' or 'IndexedTraversal' -- with access to the index. -- -- @ -- ('%@~') ≡ 'imapOf' -- @ -- -- When you do not need access to the index then ('%@~') is more liberal in what it can accept. -- -- @ -- l '%~' f ≡ l '%@~' 'const' f -- @ -- -- @ -- ('%@~') :: 'IndexedSetter' i s t a b -> (i -> a -> b) -> s -> t -- ('%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- ('%@~') :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ (%@~) :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t l %@~ f = l %~ Indexed f {-# INLINE (%@~) #-} -- | Adjust every target in the current state of an 'IndexedSetter', 'IndexedLens' or 'IndexedTraversal' -- with access to the index. -- -- When you do not need access to the index then ('%=') is more liberal in what it can accept. -- -- @ -- l '%=' f ≡ l '%@=' 'const' f -- @ -- -- @ -- ('%@=') :: 'MonadState' s m => 'IndexedSetter' i s s a b -> (i -> a -> b) -> m () -- ('%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m () -- ('%@=') :: 'MonadState' s m => 'IndexedTraversal' i s t a b -> (i -> a -> b) -> m () -- @ (%@=) :: MonadState s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m () l %@= f = State.modify (l %@~ f) {-# INLINE (%@=) #-} ------------------------------------------------------------------------------ -- Deprecated ------------------------------------------------------------------------------ -- | 'mapOf' is a deprecated alias for 'over'. mapOf :: Profunctor p => Setting p s t a b -> p a b -> s -> t mapOf = over {-# INLINE mapOf #-} {-# DEPRECATED mapOf "Use `over`" #-} -- | Map with index. (Deprecated alias for 'iover'). -- -- When you do not need access to the index, then 'mapOf' is more liberal in what it can accept. -- -- @ -- 'mapOf' l ≡ 'imapOf' l '.' 'const' -- @ -- -- @ -- 'imapOf' :: 'IndexedSetter' i s t a b -> (i -> a -> b) -> s -> t -- 'imapOf' :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- 'imapOf' :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ imapOf :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t imapOf = iover {-# INLINE imapOf #-} {-# DEPRECATED imapOf "Use `iover`" #-} lens-3.10/src/Control/Lens/Simple.hs0000644000000000000000000000473012226700613015464 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Simple -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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'" #-} lens-3.10/src/Control/Lens/TH.hs0000644000000000000000000010302512226700613014543 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} #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.TH -- Copyright : (C) 2012-13 Edward Kmett, Michael Sloan -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.TH ( -- * Constructing Lenses Automatically makeLenses, makeLensesFor , makeClassy, makeClassyFor , makeIso , makePrisms , makeWrapped , makeFields -- * Configuring Lenses , makeLensesWith , makeFieldsWith , defaultRules , defaultFieldRules , camelCaseFields , underscoreFields , LensRules(LensRules) , FieldRules(FieldRules) , lensRules , classyRules , isoRules , lensIso , lensField , lensClass , lensFlags , LensFlag(..) , simpleLenses , partialLenses , buildTraversals , handleSingletons , singletonIso , singletonRequired , createClass , createInstance , classRequired , singletonAndField , generateSignatures ) where import Control.Applicative #if !(MIN_VERSION_template_haskell(2,7,0)) import Control.Monad (ap) #endif 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.Setter import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Wrapped import Data.Char (toLower, toUpper, isUpper) import Data.Either (lefts) import Data.Foldable hiding (concat) 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.Ord (comparing) import Data.Set as Set hiding (toList,map,filter) import Data.Set.Lens import Data.Traversable hiding (mapM) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lens {-# ANN module "HLint: ignore Use foldl" #-} -- | Flags for 'Lens' construction data LensFlag = SimpleLenses | PartialLenses | BuildTraversals | SingletonAndField | SingletonIso | HandleSingletons | SingletonRequired | CreateClass | CreateInstance | ClassRequired | GenerateSignatures deriving (Eq,Ord,Show,Read) -- | Only Generate valid 'Control.Lens.Type.Simple' lenses. simpleLenses :: Lens' LensRules Bool simpleLenses = lensFlags.contains SimpleLenses -- | Enables the generation of partial lenses, generating runtime errors for -- every constructor that does not have a valid definition for the 'Lens'. This -- occurs when the constructor lacks the field, or has multiple fields mapped -- to the same 'Lens'. partialLenses :: Lens' LensRules Bool partialLenses = lensFlags.contains PartialLenses -- | In the situations that a 'Lens' would be partial, when 'partialLenses' is -- used, this flag instead causes traversals to be generated. Only one can be -- used, and if neither are, then compile-time errors are generated. buildTraversals :: Lens' LensRules Bool buildTraversals = lensFlags.contains BuildTraversals -- | Handle singleton constructors specially. handleSingletons :: Lens' LensRules Bool handleSingletons = lensFlags.contains HandleSingletons -- | When building a singleton 'Iso' (or 'Lens') for a record constructor, build -- both the 'Iso' (or 'Lens') for the record and the one for the field. singletonAndField :: Lens' LensRules Bool singletonAndField = lensFlags.contains SingletonAndField -- | Use 'Iso' for singleton constructors. singletonIso :: Lens' LensRules Bool singletonIso = lensFlags.contains SingletonIso -- | Expect a single constructor, single field newtype or data type. singletonRequired :: Lens' LensRules Bool singletonRequired = lensFlags.contains SingletonRequired -- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the 'lensClass' rule matches. createClass :: Lens' LensRules Bool createClass = lensFlags.contains CreateClass -- | Create the instance if the constructor is 'Control.Lens.Type.Simple' and the 'lensClass' rule matches. createInstance :: Lens' LensRules Bool createInstance = lensFlags.contains CreateInstance -- | Die if the 'lensClass' fails to match. classRequired :: Lens' LensRules Bool classRequired = lensFlags.contains ClassRequired -- | Indicate whether or not to supply the signatures for the generated -- lenses. -- -- Disabling this can be useful if you want to provide a more restricted type -- signature or if you want to supply hand-written haddocks. generateSignatures :: Lens' LensRules Bool generateSignatures = lensFlags.contains GenerateSignatures -- | This configuration describes the options we'll be using to make -- isomorphisms or lenses. data LensRules = LensRules { _lensIso :: String -> Maybe String , _lensField :: String -> Maybe String , _lensClass :: String -> Maybe (String, String) , _lensFlags :: Set LensFlag } -- | 'Lens'' to access the convention for naming top level isomorphisms in our -- 'LensRules'. -- -- Defaults to lowercasing the first letter of the constructor. lensIso :: Lens' LensRules (String -> Maybe String) lensIso f (LensRules i n c o) = f i <&> \i' -> LensRules i' n c o -- | 'Lens'' to access the convention for naming fields in our 'LensRules'. -- -- Defaults to stripping the _ off of the field name, lowercasing the name, and -- rejecting the field if it doesn't start with an '_'. lensField :: Lens' LensRules (String -> Maybe String) lensField f (LensRules i n c o) = f n <&> \n' -> LensRules i n' c o -- | Retrieve options such as the name of the class and method to put in it to -- build a class around monomorphic data types. lensClass :: Lens' LensRules (String -> Maybe (String, String)) lensClass f (LensRules i n c o) = f c <&> \c' -> LensRules i n c' o -- | Retrieve options such as the name of the class and method to put in it to -- build a class around monomorphic data types. lensFlags :: Lens' LensRules (Set LensFlag) lensFlags f (LensRules i n c o) = f o <&> LensRules i n c -- | Default 'LensRules'. defaultRules :: LensRules defaultRules = LensRules mLowerName fld (const Nothing) $ Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance, BuildTraversals, GenerateSignatures] where fld ('_':cs) = mLowerName cs fld _ = Nothing mLowerName :: String -> Maybe String mLowerName (c:cs) = Just (toLower c:cs) mLowerName _ = Nothing -- | Rules for making fairly simple partial lenses, ignoring the special cases -- for isomorphisms and traversals, and not making any classes. lensRules :: LensRules lensRules = defaultRules & lensIso .~ const Nothing & lensClass .~ const Nothing & handleSingletons .~ True & partialLenses .~ False & buildTraversals .~ True -- | Rules for making lenses and traversals that precompose another 'Lens'. classyRules :: LensRules classyRules = defaultRules & 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 & handleSingletons .~ True & singletonRequired .~ True & singletonAndField .~ True -- | Build lenses (and traversals) with a sensible default configuration. -- -- @ -- 'makeLenses' = 'makeLensesWith' 'lensRules' -- @ makeLenses :: Name -> Q [Dec] makeLenses = makeLensesWith lensRules -- | Make lenses and traversals for a type, and create a class when the -- type has no arguments. -- -- /e.g./ -- -- @ -- data Foo = Foo { _fooX, _fooY :: 'Int' } -- 'makeClassy' ''Foo -- @ -- -- will create -- -- @ -- class HasFoo t where -- foo :: 'Control.Lens.Type.Simple' 'Lens' t Foo -- instance HasFoo Foo where foo = 'id' -- fooX, fooY :: HasFoo t => 'Control.Lens.Type.Simple' 'Lens' t 'Int' -- @ -- -- @ -- 'makeClassy' = 'makeLensesWith' 'classyRules' -- @ 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 -- that has a single argument. -- -- /e.g./ -- -- @ -- newtype 'List' a = 'List' [a] -- 'makeIso' ''List -- @ -- -- will create -- -- @ -- 'list' :: 'Iso' [a] [b] ('List' a) ('List' b) -- @ -- -- @ -- 'makeIso' = 'makeLensesWith' 'isoRules' -- @ makeIso :: Name -> Q [Dec] makeIso = makeLensesWith isoRules -- | Derive lenses and traversals, specifying explicit pairings -- of @(fieldName, lensName)@. -- -- If you map multiple names to the same label, and it is present in the same -- constructor then this will generate a 'Traversal'. -- -- /e.g./ -- -- @ -- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo -- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar -- @ makeLensesFor :: [(String, String)] -> Name -> Q [Dec] makeLensesFor fields = makeLensesWith $ lensRules & lensField .~ (`Prelude.lookup` fields) -- | Derive lenses and traversals, using a named wrapper class, and -- specifying explicit pairings of @(fieldName, traversalName)@. -- -- Example usage: -- -- @ -- '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) -- | 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" _ -> fail "makeLensesWith: Expected the name of a data type or newtype" -- | Generate a 'Prism' for each constructor of a data type. 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" _ -> fail "makePrisms: Expected the name of a data type or newtype" ----------------------------------------------------------------------------- -- Internal TH Implementation ----------------------------------------------------------------------------- -- | Transform @NewtypeD@s declarations to @DataD@s. deNewtype :: Dec -> Dec deNewtype (NewtypeD ctx tyConName args c d) = DataD ctx tyConName 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 where conTypeVars = map (Set.fromList . toListOf typeVars) cons 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 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) 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 missClauses | List.null otherCons = [] | Map.null altArgs = [clause [varP xName] (normalB (appE (conE 'Left) (varE xName))) []] | otherwise = reviewerIdClause <$> otherCons Prelude.sequence [ sigD resName . forallT (args ++ (PlainTV <$> Map.elems altArgs)) (return $ List.nub (ctx ++ substTypeVars altArgs ctx)) $ if altArgsList == [] then conT ''Prism' `appsT` [ appsT (conT tyConName) $ 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 , toTupleT $ pure <$> fieldTypes , toTupleT $ pure <$> substTypeVars altArgs fieldTypes ] , funD resName [ clause [] (normalB (appsE [varE 'prism, varE remitterName, varE reviewerName])) [ funD remitterName [ clause [toTupleP (varP <$> varNames)] (normalB (appsE (conE dataConName : fmap varE varNames))) [] ] , funD reviewerName $ hitClause : missClauses ] ] ] where (dataConName, fieldTypes) = ctrNameAndFieldTypes con conArgs = setOf typeVars fieldTypes isAltArg arg = canModifyTypeVar arg && conArgs^.contains(arg^.name) ctrNameAndFieldTypes :: Con -> (Name, [Type]) ctrNameAndFieldTypes (NormalC n ts) = (n, snd <$> ts) ctrNameAndFieldTypes (RecC n ts) = (n, view _3 <$> ts) ctrNameAndFieldTypes (InfixC l n r) = (n, [snd l, snd r]) ctrNameAndFieldTypes (ForallC _ _ c) = ctrNameAndFieldTypes c -- When a 'Prism' can change type variables it needs to pattern match on all -- other data constructors and rebuild the data so it will have the new type. reviewerIdClause :: Con -> ClauseQ reviewerIdClause con = do let (dataConName, fieldTypes) = ctrNameAndFieldTypes con 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)) [] 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 makeIsoFrom :: Name -> ExpQ makeIsoFrom conName = do b <- newName "b" lamE [conP conName [varP b]] $ varE b makeIsoBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ makeIsoBody lensName conName f g = funD lensName [clause [] (normalB body) []] where body = appsE [ varE 'iso , g conName , f conName ] makeLensBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ makeLensBody lensName conName i o = do f <- newName "f" a <- newName "a" funD lensName [clause [] (normalB ( lamE [varP f, varP a] $ appsE [ varE 'fmap , o conName , varE f `appE` (i conName `appE` varE a) ])) []] plain :: TyVarBndr -> TyVarBndr plain (KindedTV t _) = PlainTV t 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 makeIsoLenses :: LensRules -> Cxt -> Name -> [TyVarBndr] -> Name -> Maybe Name -> Type -> Q [Dec] makeIsoLenses cfg ctx tyConName tyArgs0 dataConName maybeFieldName partTy = do let tyArgs = map plain tyArgs0 m <- freshMap $ setOf typeVars tyArgs let aty = partTy bty = substTypeVars m aty cty = appArgs (ConT tyConName) tyArgs dty = substTypeVars m cty quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) (ctx ++ substTypeVars m ctx) maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName) lensOnly = not $ cfg^.singletonIso isoCon | lensOnly = ConT ''Lens | otherwise = ConT ''Iso isoCon' | lensOnly = ConT ''Lens' | otherwise = ConT ''Iso' makeBody | lensOnly = makeLensBody | otherwise = makeIsoBody isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do let decl = SigD isoName $ quantified $ if cfg^.simpleLenses || Map.null m then isoCon' `apps` [aty,cty] else isoCon `apps` [aty,bty,cty,dty] body <- makeBody isoName dataConName makeIsoFrom makeIsoTo #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else inlining <- inlinePragma isoName return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining] #endif accessorDecls <- case mkName <$> (maybeFieldName >>= view lensField cfg . nameBase) of jfn@(Just lensName) | (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do let decl = SigD lensName $ quantified $ if cfg^.simpleLenses || Map.null m then isoCon' `apps` [cty,aty] else isoCon `apps` [cty,dty,aty,bty] body <- makeBody lensName dataConName makeIsoTo makeIsoFrom #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else inlining <- inlinePragma lensName return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining] #endif _ -> return [] return $ isoDecls ++ accessorDecls makeFieldLensBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec makeFieldLensBody isTraversal lensName conList maybeMethodName = case maybeMethodName of Just methodName -> do go <- newName "go" let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go) funD lensName [ clause [] (normalB expr) [funD go clauses] ] Nothing -> funD lensName clauses where clauses = map buildClause conList buildClause (con, fields) = do f <- newName "_f" vars <- for (con^..conNamedFields._1) $ \fld -> if fld `List.elem` fields then Left <$> ((,) <$> newName ('_':(nameBase fld++"'")) <*> newName ('_':nameBase fld)) else Right <$> newName ('_':nameBase fld) let cpats = map (varP . either fst id) vars -- Deconstruction cvals = map (varE . either snd id) vars -- Reconstruction 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 expr | not isTraversal && length fields /= 1 = appE (varE 'error) . litE . stringL $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields) | List.null fields = appE (varE 'pure) recon | otherwise = let step Nothing r = Just $ infixE (Just $ lamE fpats recon) (varE '(<$>)) (Just r) step (Just l) r = Just $ infixE (Just l) (varE '(<*>)) (Just r) in fromJust $ List.foldl step Nothing fvals -- = 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) [] makeFieldLenses :: LensRules -> Cxt -- ^ surrounding cxt driven by the data type context -> Name -- ^ data/newtype constructor name -> [TyVarBndr] -- ^ args -> [Con] -> Q [Dec] makeFieldLenses cfg ctx tyConName tyArgs0 cons = do let tyArgs = map plain tyArgs0 maybeLensClass = view lensClass cfg $ nameBase tyConName maybeClassName = fmap (^._1.to mkName) maybeLensClass t <- newName "t" a <- newName "a" --TODO: there's probably a more efficient way to do this. lensFields <- map (\xs -> (fst $ head xs, map snd xs)) . groupBy ((==) `on` fst) . sortBy (comparing fst) . concat <$> mapM (getLensFields $ view lensField cfg) cons -- varMultiSet knows how many usages of the type variables there are. let varMultiSet = List.concatMap (toListOf (conFields._2.typeVars)) cons varSet = Set.fromList $ map (view name) tyArgs bodies <- for lensFields $ \(lensName, fields) -> do let fieldTypes = map (view _3) fields -- All of the polymorphic variables not involved in these fields otherVars = varMultiSet List.\\ fieldTypes^..typeVars -- New type variable binders, and the type to represent the selected fields (tyArgs', cty) <- unifyTypes tyArgs fieldTypes -- 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' bty = substTypeVars m aty dty = substTypeVars m cty s = setOf folded m relevantBndr b = s^.contains (b^.name) relevantCtx = not . Set.null . Set.intersection s . setOf typeVars tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs') ps = filter relevantCtx (substTypeVars m ctx) qs = case maybeClassName of Just n | not (cfg^.createClass) -> ClassP n [VarT t] : (ctx ++ ps) | otherwise -> ps _ -> ctx ++ ps tvs' = case maybeClassName of Just _ | not (cfg^.createClass) -> PlainTV t : tvs | otherwise -> [] _ -> tvs --TODO: Better way to write this? fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields conList = map (\c -> (c, Map.findWithDefault [] (view name c) fieldMap)) cons maybeMethodName = fmap (mkName . view _2) maybeLensClass isTraversal <- do let notSingular = filter ((/= 1) . length . snd) conList showCon (c, fs) = pprint (c^.name) ++ " { " ++ intercalate ", " (map pprint fs) ++ " }" case (cfg^.buildTraversals, cfg^.partialLenses) of (True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses." (False, True) -> return False (True, False) | List.null notSingular -> return False | otherwise -> return True (False, False) | List.null notSingular -> return False | otherwise -> fail . unlines $ [ "Cannot use 'makeLensesWith' with constructors that don't map just one field" , "to a lens, without using either the buildTraversals or partialLenses flags." , if length conList == 1 then "The following constructor failed this criterion for the " ++ pprint lensName ++ " lens:" else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:" ] ++ map showCon conList let decl = SigD lensName $ ForallT tvs' qs vars where vars | aty == bty && cty == dty || cfg^.simpleLenses || isJust maybeClassName = apps (ConT (if isTraversal then ''Traversal' else ''Lens')) [aty,cty] | otherwise = apps (ConT (if isTraversal then ''Traversal else ''Lens)) [aty,bty,cty,dty] body <- makeFieldLensBody isTraversal lensName conList maybeMethodName #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else inlining <- inlinePragma lensName return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining] #endif let defs = Prelude.concat bodies case maybeLensClass of Nothing -> return defs Just (clsNameString, methodNameString) -> do let clsName = mkName clsNameString methodName = mkName methodNameString varArgs = varT . view name <$> tyArgs appliedCon = conT tyConName `appsT` varArgs Prelude.sequence $ filter (\_ -> cfg^.createClass) [ classD (return []) clsName (PlainTV t : tyArgs) (if List.null tyArgs then [] else [FunDep [t] (view name <$> tyArgs)]) ( sigD methodName (appsT (conT ''Lens') [varT t, appliedCon]) : map return defs)] ++ filter (\_ -> cfg^.createInstance) [ instanceD (return []) ((conT clsName `appT` appliedCon) `appsT` varArgs) [ funD methodName [clause [varP a] (normalB (varE a)) []] #ifdef INLINING , inlinePragma methodName #endif ]] ++ filter (\_ -> not $ cfg^.createClass) (map return defs) -- | Gets @[(lens name, (constructor name, field name, type))]@ from a record constructor. getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))] getLensFields f (RecC cn fs) = return . catMaybes $ fs <&> \(fn,_,t) -> f (nameBase fn) <&> \ln -> (mkName ln, (cn,fn,t)) getLensFields _ _ = return [] -- TODO: properly fill this out -- -- Ideally this would unify the different field types, and figure out which polymorphic variables -- need to be the same. For now it just leaves them the same and yields the first type. -- (This leaves us open to inscrutable compile errors in the generated code) unifyTypes :: [TyVarBndr] -> [Type] -> Q ([TyVarBndr], Type) unifyTypes tvs tys = return (tvs, head tys) -- | Build 'Wrapped' instance for a given newtype makeWrapped :: Name -> DecsQ 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" _ -> 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 tyNameRemap <- makeNameRemap tyNames (newtypeConName, fieldType) <- case ctrNameAndFieldTypes con of (a,[b]) -> return (a,b) _ -> fail "makeWrappedInstance: Constructor must have a single field" let outer1 = conT tyConName `appsT` fmap varT tyNames inner1 = return fieldType outer2 = conT tyConName `appsT` fmap (varT . snd) tyNameRemap inner2 = return $ substTypeVars (Map.fromList tyNameRemap) fieldType dec <- instanceD (cxt []) (conT ''Wrapped `appsT` [inner1, inner2, outer1, outer2]) [makeIsoBody 'wrapped newtypeConName makeIsoFrom makeIsoTo] 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) #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 pure = return (<*>) = ap #endif #ifdef INLINING inlinePragma :: Name -> Q Dec #if MIN_VERSION_template_haskell(2,8,0) # ifdef OLD_INLINE_PRAGMAS -- 7.6rc1? inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase Inline False # else -- 7.7.20120830 inlinePragma methodName = pragInlD methodName Inline FunLike AllPhases # endif #else -- GHC <7.6, TH <2.8.0 inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase True False #endif #endif data FieldRules = FieldRules { _getPrefix :: String -> Maybe String , _rawLensNaming :: String -> String , _niceLensNaming :: String -> Maybe String , _classNaming :: String -> Maybe String } data Field = Field { _fieldName :: Name , _fieldLensPrefix :: String , _fieldLensName :: Name , _fieldClassName :: Name , _fieldClassLensName :: Name } overHead :: (a -> a) -> [a] -> [a] overHead _ [] = [] overHead f (x:xs) = f x : xs -- | Field rules for fields in the form @ _prefix_fieldname @ underscoreFields :: FieldRules underscoreFields = FieldRules prefix rawLens niceLens classNaming where prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs) prefix _ = Nothing rawLens x = x ++ "_lens" niceLens x = prefix x <&> \n -> drop (length n + 2) x classNaming x = niceLens x <&> ("Has_" ++) -- | Field rules for fields in the form @ prefixFieldname @ camelCaseFields :: FieldRules camelCaseFields = FieldRules prefix rawLens niceLens classNaming where sep 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 rawLens x = x ++ "Lens" niceLens x = overHead toLower . snd <$> sep x classNaming x = niceLens x <&> \ (n:ns) -> "Has" ++ toUpper n : ns collectRecords :: [Con] -> [VarStrictType] collectRecords cons = rs where recs = filter (\r -> case r of RecC{} -> True; _ -> False) cons 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)) where makeLenses' fields' = makeLensesWith $ lensRules & lensField .~ (`Prelude.lookup` fields') & buildTraversals .~ False & partialLenses .~ True mkFields :: FieldRules -> [VarStrictType] -> [Field] mkFields (FieldRules prefix' raw' nice' clas') rs = Maybe.mapMaybe namer rs & List.groupBy (on (==) _fieldLensPrefix) & (\ gs -> case gs of x:_ -> x _ -> []) where namer (n', _, _) = do let field = nameBase n' rawlens = mkName (raw' field) prefix <- prefix' 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 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" fmap concat . forM (mkFields cfg rs) $ \(Field field _ fullLensName className lensName) -> do classHas <- classD (return []) className [ PlainTV c, PlainTV e ] [ FunDep [c] [e] ] [ sigD lensName (conT ''Lens' `appsT` [varT c, varT e])] fieldType <- do VarI _ t _ _ <- reify field case t of AppT _ fieldType -> return fieldType ForallT _ [] (AppT _ fieldType) -> return fieldType _ -> error "Cannot get fieldType" instanceHas <- instanceD (return []) (conT className `appsT` [conT src `appsT` map (varT.view name) vs, return fieldType]) [ #ifdef INLINING inlinePragma lensName, #endif funD lensName [ clause [] (normalB (global 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) -- | @ makeFields = 'makeFieldsWith' 'defaultFieldRules' @ makeFields :: Name -> Q [Dec] makeFields = makeFieldsWith defaultFieldRules -- | @ defaultFieldRules = 'camelCaseFields' @ defaultFieldRules :: FieldRules defaultFieldRules = camelCaseFields lens-3.10/src/Control/Lens/Traversal.hs0000644000000000000000000011564212226700613016203 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- A @'Traversal' s t a b@ is a generalization of 'traverse' from -- 'Traversable'. It allows you to 'traverse' over a structure and change out -- its contents with monadic or 'Applicative' side-effects. Starting from -- -- @ -- 'traverse' :: ('Traversable' t, 'Applicative' f) => (a -> f b) -> t a -> f (t b) -- @ -- -- we monomorphize the contents and result to obtain -- -- @ -- type 'Traversal' s t a b = forall f. 'Applicative' f => (a -> f b) -> s -> f t -- @ -- -- While a 'Traversal' isn't quite a 'Fold', it _can_ be used for -- 'Control.Lens.Getter.Getting' like a 'Fold', because given a -- 'Data.Monoid.Monoid' @m@, we have an 'Applicative' -- for @('Const' m)@. Everything you know how to do with a 'Traversable' -- container, you can with with a 'Traversal', and here we provide -- combinators that generalize the usual 'Traversable' operations. ---------------------------------------------------------------------------- module Control.Lens.Traversal ( -- * Traversals Traversal, Traversal' , IndexedTraversal, IndexedTraversal' , ATraversal, ATraversal' , AnIndexedTraversal, AnIndexedTraversal' , Traversing, Traversing' -- * Traversing and Lensing , traverseOf, forOf, sequenceAOf , mapMOf, forMOf, sequenceOf , transposeOf , mapAccumLOf, mapAccumROf , scanr1Of, scanl1Of , failover -- * Monomorphic Traversals , cloneTraversal , cloneIndexPreservingTraversal , cloneIndexedTraversal -- * Parts and Holes , partsOf, partsOf' , unsafePartsOf, unsafePartsOf' , holesOf , singular, unsafeSingular -- * Common Traversals , Traversable(traverse) , both , beside , taking , dropping -- * Indexed Traversals -- ** Common , ignored , TraverseMin(..) , TraverseMax(..) , traversed , traversed64 , elementOf , element , elementsOf , elements -- ** Combinators , ipartsOf , ipartsOf' , iunsafePartsOf , iunsafePartsOf' , itraverseOf , iforOf , imapMOf , iforMOf , imapAccumROf , imapAccumLOf -- * Implementation Details , Bazaar(..) , Bazaar' , loci , iloci ) where import Control.Applicative as Applicative import Control.Applicative.Backwards import Control.Category import Control.Comonad import Control.Monad 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.Type import Control.Monad.Trans.State.Lazy import Data.Functor.Compose import Data.Int import Data.IntMap as IntMap import Data.Map as Map import Data.Monoid import Data.Traversable import Data.Tuple (swap) import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Prelude hiding ((.),id) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate) -- >>> import Data.Maybe (fromMaybe) -- >>> 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 ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------ -- | When you see this as an argument to a function, it expects a 'Traversal'. type ATraversal s t a b = LensLike (Bazaar (->) a b) s t a b -- | @ -- type 'ATraversal'' = 'Simple' 'ATraversal' -- @ type ATraversal' s a = ATraversal 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 -- | @ -- type 'AnIndexedTraversal'' = 'Simple' ('AnIndexedTraversal' i) -- @ type AnIndexedTraversal' i s a = AnIndexedTraversal 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, -- -- * to be unindexed if @p@ is @(->)@, -- -- * a 'Traversal' if @f@ is 'Applicative', -- -- * a 'Getter' if @f@ is only 'Gettable', -- -- * a 'Lens' if @p@ is only a 'Functor', -- -- * 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 'Traversing'' f = 'Simple' ('Traversing' f) -- @ type Traversing' p f s a = Traversing p f s s a a -------------------------- -- Traversal Combinators -------------------------- -- | Map each element of a structure targeted by a 'Lens' or 'Traversal', -- evaluate these actions from left to right, and collect the results. -- -- This function is only provided for consistency, 'id' is strictly more general. -- -- >>> traverseOf each print (1,2,3) -- 1 -- 2 -- 3 -- ((),(),()) -- -- @ -- 'traverseOf' ≡ 'id' -- 'itraverseOf' l ≡ 'traverseOf' l '.' 'Indexed' -- @ -- -- -- This yields the obvious law: -- -- @ -- 'traverse' ≡ 'traverseOf' 'traverse' -- @ -- -- @ -- 'traverseOf' :: 'Functor' f => 'Iso' s t a b -> (a -> f b) -> s -> f t -- 'traverseOf' :: 'Functor' f => 'Lens' s t a b -> (a -> f b) -> s -> f t -- 'traverseOf' :: 'Applicative' f => 'Traversal' s t a b -> (a -> f b) -> s -> f t -- @ traverseOf :: Over p f s t a b -> p a (f b) -> s -> f t traverseOf = id {-# INLINE traverseOf #-} -- | A version of 'traverseOf' with the arguments flipped, such that: -- -- >>> forOf each (1,2,3) print -- 1 -- 2 -- 3 -- ((),(),()) -- -- This function is only provided for consistency, 'flip' is strictly more general. -- -- @ -- 'forOf' ≡ 'flip' -- 'forOf' ≡ 'flip' . 'traverseOf' -- @ -- -- @ -- 'for' ≡ 'forOf' 'traverse' -- 'Control.Lens.Indexed.ifor' l s ≡ 'for' l s '.' 'Indexed' -- @ -- -- @ -- 'forOf' :: 'Functor' f => 'Iso' s t a b -> s -> (a -> f b) -> f t -- 'forOf' :: 'Functor' f => 'Lens' s t a b -> s -> (a -> f b) -> f t -- 'forOf' :: 'Applicative' f => 'Traversal' s t a b -> s -> (a -> f b) -> f t -- @ forOf :: Over p f s t a b -> s -> p a (f b) -> f t forOf = flip {-# INLINE forOf #-} -- | Evaluate each action in the structure from left to right, and collect -- the results. -- -- >>> sequenceAOf both ([1,2],[3,4]) -- [(1,3),(1,4),(2,3),(2,4)] -- -- @ -- 'sequenceA' ≡ 'sequenceAOf' 'traverse' ≡ 'traverse' 'id' -- 'sequenceAOf' l ≡ 'traverseOf' l 'id' ≡ l 'id' -- @ -- -- @ -- 'sequenceAOf' :: 'Functor' f => 'Iso' s t (f b) b -> s -> f t -- 'sequenceAOf' :: 'Functor' f => 'Lens' s t (f b) b -> s -> f t -- 'sequenceAOf' :: 'Applicative' f => 'Traversal' s t (f b) b -> s -> f t -- @ sequenceAOf :: LensLike f s t (f b) b -> s -> f t sequenceAOf l = l id {-# INLINE sequenceAOf #-} -- | Map each element of a structure targeted by a 'Lens' to a monadic action, -- evaluate these actions from left to right, and collect the results. -- -- >>> mapMOf both (\x -> [x, x + 1]) (1,3) -- [(1,3),(1,4),(2,3),(2,4)] -- -- @ -- 'mapM' ≡ 'mapMOf' 'traverse' -- 'imapMOf' l ≡ 'forM' l '.' 'Indexed' -- @ -- -- @ -- 'mapMOf' :: 'Monad' m => 'Iso' s t a b -> (a -> m b) -> s -> m t -- 'mapMOf' :: 'Monad' m => 'Lens' s t a b -> (a -> m b) -> s -> m t -- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t -- @ mapMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t mapMOf l cmd = unwrapMonad #. l (WrapMonad #. cmd) {-# INLINE mapMOf #-} -- | 'forMOf' is a flipped version of 'mapMOf', consistent with the definition of 'forM'. -- -- >>> forMOf both (1,3) $ \x -> [x, x + 1] -- [(1,3),(1,4),(2,3),(2,4)] -- -- @ -- 'forM' ≡ 'forMOf' 'traverse' -- 'forMOf' l ≡ 'flip' ('mapMOf' l) -- 'iforMOf' l s ≡ 'forM' l s '.' 'Indexed' -- @ -- -- @ -- 'forMOf' :: 'Monad' m => 'Iso' s t a b -> s -> (a -> m b) -> m t -- 'forMOf' :: 'Monad' m => 'Lens' s t a b -> s -> (a -> m b) -> m t -- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t -- @ forMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> s -> p a (m b) -> m t forMOf l a cmd = unwrapMonad (l (WrapMonad #. cmd) a) {-# INLINE forMOf #-} -- | Sequence the (monadic) effects targeted by a 'Lens' in a container from left to right. -- -- >>> sequenceOf each ([1,2],[3,4],[5,6]) -- [(1,3,5),(1,3,6),(1,4,5),(1,4,6),(2,3,5),(2,3,6),(2,4,5),(2,4,6)] -- -- @ -- 'sequence' ≡ 'sequenceOf' 'traverse' -- 'sequenceOf' l ≡ 'mapMOf' l 'id' -- 'sequenceOf' l ≡ 'unwrapMonad' '.' l 'WrapMonad' -- @ -- -- @ -- 'sequenceOf' :: 'Monad' m => 'Iso' s t (m b) b -> s -> m t -- 'sequenceOf' :: 'Monad' m => 'Lens' s t (m b) b -> s -> m t -- 'sequenceOf' :: 'Monad' m => 'Traversal' s t (m b) b -> s -> m t -- @ sequenceOf :: LensLike (WrappedMonad m) s t (m b) b -> s -> m t sequenceOf l = unwrapMonad #. l WrapMonad {-# INLINE sequenceOf #-} -- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'. -- -- Note: 'Data.List.transpose' handles ragged inputs more intelligently, but for non-ragged inputs: -- -- >>> transposeOf traverse [[1,2,3],[4,5,6]] -- [[1,4],[2,5],[3,6]] -- -- @ -- 'Data.List.transpose' ≡ 'transposeOf' 'traverse' -- @ -- -- Since every 'Lens' is a 'Traversal', we can use this as a form of -- monadic strength as well: -- -- @ -- 'transposeOf' 'Control.Lens.Tuple._2' :: (b, [a]) -> [(b, a)] -- @ transposeOf :: LensLike ZipList s t [a] a -> s -> [t] transposeOf l = getZipList #. l ZipList {-# INLINE transposeOf #-} -- | This generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'. -- -- @ -- 'mapAccumR' ≡ 'mapAccumROf' 'traverse' -- @ -- -- 'mapAccumROf' accumulates 'State' from right to left. -- -- @ -- 'mapAccumROf' :: 'Iso' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumROf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumROf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ -- -- @ -- 'mapAccumROf' :: 'LensLike' ('Backwards' ('State' acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ mapAccumROf :: Conjoined p => Over p (Backwards (State acc)) s t a b -> p acc (a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumROf = mapAccumLOf . backwards {-# INLINE mapAccumROf #-} -- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. -- -- @ -- 'mapAccumL' ≡ 'mapAccumLOf' 'traverse' -- @ -- -- 'mapAccumLOf' accumulates 'State' from left to right. -- -- @ -- 'mapAccumLOf' :: 'Iso' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumLOf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumLOf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ -- -- @ -- 'mapAccumLOf' :: 'LensLike' ('State' acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumLOf' l f acc0 s = 'swap' ('runState' (l (\a -> 'state' (\acc -> 'swap' (f acc a))) s) acc0) -- @ -- mapAccumLOf :: Conjoined p => Over p (State acc) s t a b -> p acc (a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumLOf l f acc0 s = swap (runState (l g s) acc0) where g = cotabulate $ \wa -> state $ \acc -> swap (corep f (acc <$ wa) (extract wa)) -- This would be much cleaner if the argument order for the function was swapped. {-# INLINE mapAccumLOf #-} -- | This permits the use of 'scanr1' over an arbitrary 'Traversal' or 'Lens'. -- -- @ -- 'scanr1' ≡ 'scanr1Of' 'traverse' -- @ -- -- @ -- 'scanr1Of' :: 'Iso' s t a a -> (a -> a -> a) -> s -> t -- 'scanr1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t -- 'scanr1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t -- @ scanr1Of :: LensLike (Backwards (State (Maybe a))) s t a a -> (a -> a -> a) -> s -> t scanr1Of l f = snd . mapAccumROf l step Nothing where step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f a s {-# INLINE scanr1Of #-} -- | This permits the use of 'scanl1' over an arbitrary 'Traversal' or 'Lens'. -- -- @ -- 'scanl1' ≡ 'scanl1Of' 'traverse' -- @ -- -- @ -- 'scanl1Of' :: 'Iso' s t a a -> (a -> a -> a) -> s -> t -- 'scanl1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t -- 'scanl1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t -- @ scanl1Of :: LensLike (State (Maybe a)) s t a a -> (a -> a -> a) -> s -> t scanl1Of l f = snd . mapAccumLOf l step Nothing where step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f s a {-# INLINE scanl1Of #-} -- | This 'Traversal' allows you to 'traverse' the individual stores in a 'Bazaar'. loci :: Traversal (Bazaar (->) a c s) (Bazaar (->) b c s) a b loci f w = getCompose (runBazaar w (Compose #. fmap sell . f)) {-# INLINE loci #-} -- | This 'IndexedTraversal' allows you to 'traverse' the individual stores in -- a 'Bazaar' with access to their indices. iloci :: IndexedTraversal i (Bazaar (Indexed i) a c s) (Bazaar (Indexed i) b c s) a b iloci f w = getCompose (runBazaar w (Compose #. Indexed (\i -> fmap (indexed sell i) . indexed f i))) {-# INLINE iloci #-} ------------------------------------------------------------------------------- -- Parts and Holes ------------------------------------------------------------------------------- -- | 'partsOf' turns a 'Traversal' into a 'Lens' that resembles an early version of the 'Data.Data.Lens.uniplate' (or 'Data.Data.Lens.biplate') type. -- -- /Note:/ You should really try to maintain the invariant of the number of children in the list. -- -- Any extras will be lost. If you do not supply enough, then the remainder will come from the original structure. -- -- 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'. -- -- @ -- 'partsOf' :: 'Iso'' s a -> 'Lens'' s [a] -- 'partsOf' :: 'Lens'' s a -> 'Lens'' s [a] -- 'partsOf' :: 'Traversal'' s a -> 'Lens'' s [a] -- 'partsOf' :: 'Fold' s a -> 'Getter' s [a] -- 'partsOf' :: 'Getter' s a -> 'Getter' s [a] -- @ partsOf :: Functor f => Traversing (->) f s t a a -> LensLike f s t [a] [a] partsOf l f s = outs b <$> f (ins b) where b = l sell s {-# INLINE partsOf #-} -- | An indexed version of 'partsOf' that receives the entire list of indices as its index. ipartsOf :: forall i p f s t a. (Indexable [i] p, Functor f) => Traversing (Indexed i) f s t a a -> Over p f s t [a] [a] ipartsOf l f s = outs b <$> indexed f (is :: [i]) as where (is,as) = unzip (pins b) b = l sell s {-# INLINE ipartsOf #-} -- | A type-restricted version of 'partsOf' that can only be used with a 'Traversal'. partsOf' :: ATraversal s t a a -> Lens s t [a] [a] partsOf' l f s = outs b <$> f (ins b) where b = l sell s {-# INLINE partsOf' #-} -- | A type-restricted version of 'ipartsOf' that can only be used with an 'IndexedTraversal'. ipartsOf' :: forall i p f s t a. (Indexable [i] p, Functor f) => Over (Indexed i) (Bazaar' (Indexed i) a) s t a a -> Over p f s t [a] [a] ipartsOf' l f s = outs b <$> indexed f (is :: [i]) as where (is,as) = unzip (pins b) b = l sell s {-# INLINE ipartsOf' #-} -- | 'unsafePartsOf' turns a 'Traversal' into a 'Data.Data.Lens.uniplate' (or 'Data.Data.Lens.biplate') family. -- -- If you do not need the types of @s@ and @t@ to be different, it is recommended that -- you use 'partsOf'. -- -- It is generally safer to traverse with the 'Bazaar' rather than use this -- combinator. However, it is sometimes convenient. -- -- This is unsafe because if you don't supply at least as many @b@'s as you were -- given @a@'s, then the reconstruction of @t@ /will/ result in an error! -- -- When applied to a 'Fold' the result is merely a 'Getter' (and becomes safe). -- -- @ -- 'unsafePartsOf' :: 'Iso' s t a b -> 'Lens' s t [a] [b] -- 'unsafePartsOf' :: 'Lens' s t a b -> 'Lens' s t [a] [b] -- 'unsafePartsOf' :: 'Traversal' s t a b -> 'Lens' s t [a] [b] -- 'unsafePartsOf' :: 'Fold' s a -> 'Getter' s [a] -- 'unsafePartsOf' :: 'Getter' s a -> 'Getter' s [a] -- @ unsafePartsOf :: Functor f => Traversing (->) f s t a b -> LensLike f s t [a] [b] unsafePartsOf l f s = unsafeOuts b <$> f (ins b) where b = l sell s {-# INLINE unsafePartsOf #-} -- | An indexed version of 'unsafePartsOf' that receives the entire list of indices as its index. iunsafePartsOf :: forall i p f s t a b. (Indexable [i] p, Functor f) => Traversing (Indexed i) f s t a b -> Over p f s t [a] [b] iunsafePartsOf l f s = unsafeOuts b <$> indexed f (is :: [i]) as where (is,as) = unzip (pins b) b = l sell s {-# INLINE iunsafePartsOf #-} unsafePartsOf' :: ATraversal s t a b -> Lens s t [a] [b] unsafePartsOf' l f s = unsafeOuts b <$> f (ins b) where b = l sell s {-# INLINE unsafePartsOf' #-} iunsafePartsOf' :: forall i s t a b. Over (Indexed i) (Bazaar (Indexed i) a b) s t a b -> IndexedLens [i] s t [a] [b] iunsafePartsOf' l f s = unsafeOuts b <$> indexed f (is :: [i]) as where (is,as) = unzip (pins b) b = l sell s {-# INLINE iunsafePartsOf' #-} -- | The one-level version of 'Control.Lens.Plated.contextsOf'. This extracts a list of the immediate children according to a given 'Traversal' as editable contexts. -- -- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the values, 'Control.Comonad.Store.Class.peek' at what the structure would be like with an edited result, or simply 'extract' the original structure. -- -- @ -- propChildren l x = childrenOf l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x) -- propId l x = 'all' ('==' x) ['extract' w | w <- 'holesOf' l x] -- @ -- -- @ -- 'holesOf' :: 'Iso'' s a -> s -> ['Pretext'' (->) a s] -- 'holesOf' :: 'Lens'' s a -> s -> ['Pretext'' (->) a s] -- 'holesOf' :: 'Traversal'' s a -> s -> ['Pretext'' (->) a s] -- 'holesOf' :: 'IndexedLens'' i s a -> s -> ['Pretext'' ('Indexed' i) a s] -- 'holesOf' :: 'IndexedTraversal'' i s a -> s -> ['Pretext'' ('Indexed' i) a s] -- @ holesOf :: Conjoined p => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t] holesOf l s = f (pins b) (unsafeOuts b) where b = l sell s f [] _ = [] f (wx:xs) g = Pretext (\wxfy -> g . (:Prelude.map extract xs) <$> corep wxfy wx) : f xs (g . (extract wx:)) {-# INLINE holesOf #-} -- | This converts a 'Traversal' that you \"know\" will target one or more elements to a 'Lens'. It can -- also be used to transform a non-empty 'Fold' into a 'Getter' or a non-empty 'MonadicFold' into an -- 'Action'. -- -- The resulting 'Lens', 'Getter', or 'Action' will be partial if the supplied 'Traversal' returns -- no results. -- -- @ -- 'singular' :: 'Traversal' s t a a -> 'Lens' s t a a -- 'singular' :: 'Fold' s a -> 'Getter' s a -- 'singular' :: 'MonadicFold' m s a -> 'Action' m s a -- 'singular' :: 'IndexedTraversal' i s t a a -> 'IndexedLens' i s t a a -- 'singular' :: 'IndexedFold' i s a -> 'IndexedGetter' i s a -- '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 -> Over p f s t a a singular l pafb s = case pins b of (w:ws) -> unsafeOuts b . (:Prelude.map extract ws) <$> corep pafb w [] -> unsafeOuts b . return <$> corep pafb (error "singular: empty traversal") where b = l sell s {-# INLINE singular #-} -- | This converts a 'Traversal' that you \"know\" will target only one element to a 'Lens'. It can also be -- used to transform a 'Fold' into a 'Getter' or a 'MonadicFold' into an 'Action'. -- -- The resulting 'Lens', 'Getter', or 'Action' will be partial if the 'Traversal' targets nothing -- or more than one element. -- -- @ -- 'unsafeSingular' :: 'Traversal' s t a b -> 'Lens' s t a b -- 'unsafeSingular' :: 'Fold' s a -> 'Getter' s a -- 'unsafeSingular' :: 'MonadicFold' m s a -> 'Action' m s a -- 'unsafeSingular' :: 'IndexedTraversal' i s t a b -> 'IndexedLens' i s t a b -- 'unsafeSingular' :: 'IndexedFold' i s a -> 'IndexedGetter' i s a -- '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 -> Over p f s t a b unsafeSingular l pafb s = case pins b of [w] -> unsafeOuts b . return <$> corep pafb w [] -> error "unsafeSingular: empty traversal" _ -> error "unsafeSingular: traversing multiple results" where b = l sell s {-# INLINE unsafeSingular #-} ------------------------------------------------------------------------------ -- Internal functions used by 'partsOf', 'holesOf', etc. ------------------------------------------------------------------------------ ins :: Bizarre (->) w => w a b t -> [a] ins = toListOf (coerced bazaar) {-# INLINE ins #-} pins :: (Bizarre p w, Corepresentable p) => w a b t -> [Corep p a] pins = getConst #. bazaar (cotabulate $ \ra -> Const [ra]) {-# INLINE pins #-} parr :: (Profunctor p, Category p) => (a -> b) -> p a b parr f = lmap f id {-# INLINE parr #-} outs :: (Bizarre p w, Category p) => w a a t -> [a] -> t outs = evalState `rmap` bazaar (parr (state . unconsWithDefault)) {-# INLINE outs #-} unsafeOuts :: (Bizarre p w, Corepresentable p) => w a b t -> [b] -> t unsafeOuts = evalState `rmap` bazaar (cotabulate (\_ -> state (unconsWithDefault fakeVal))) where fakeVal = error "unsafePartsOf': not enough elements were supplied" {-# INLINE unsafeOuts #-} unconsWithDefault :: a -> [a] -> (a,[a]) unconsWithDefault d [] = (d,[]) unconsWithDefault _ (x:xs) = (x,xs) {-# INLINE unconsWithDefault #-} ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------ -- | Traverse both parts of a tuple with matching types. -- -- >>> both *~ 10 $ (1,2) -- (10,20) -- -- >>> over both length ("hello","world") -- (5,5) -- -- >>> ("hello","world")^.both -- "helloworld" both :: Traversal (a,a) (b,b) a b both f ~(a,a') = (,) <$> f a <*> f a' {-# INLINE both #-} -- | Apply a different 'Traversal' or 'Fold' to each side of a tuple. -- -- @ -- '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 -- 'beside' :: 'Getter' s a -> 'Getter' s' a -> 'Fold' (s,s') a -- 'beside' :: 'Action' m s a -> 'Action' m s' a -> 'MonadicFold' m (s,s') a -- 'beside' :: 'MonadicFold' m s a -> 'MonadicFold' m s' a -> 'MonadicFold' m (s,s') a -- @ -- -- @ -- 'beside' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b -- 'beside' :: 'IndexedLens' i s t a b -> 'IndexedLens' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b -- 'beside' :: 'IndexedFold' i s a -> 'IndexedFold' i s' a -> 'IndexedFold' i (s,s') a -- 'beside' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s' a -> 'IndexedFold' i (s,s') a -- 'beside' :: 'IndexedAction' i m s a -> 'IndexedAction' i m s' a -> 'IndexedMonadicFold' i m (s,s') a -- 'beside' :: 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s' a -> 'IndexedMonadicFold' i m (s,s') a -- @ -- -- @ -- 'beside' :: 'IndexPreservingTraversal' s t a b -> 'IndexPreservingTraversal' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b -- 'beside' :: 'IndexPreservingLens' s t a b -> 'IndexPreservingLens' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b -- 'beside' :: 'IndexPreservingFold' s a -> 'IndexPreservingFold' s' a -> 'IndexPreservingFold' (s,s') a -- 'beside' :: 'IndexPreservingGetter' s a -> 'IndexPreservingGetter' s' a -> 'IndexPreservingFold' (s,s') a -- 'beside' :: 'IndexPreservingAction' m s a -> 'IndexPreservingAction' m s' a -> 'IndexPreservingMonadicFold' m (s,s') a -- 'beside' :: 'IndexPreservingMonadicFold' m s a -> 'IndexPreservingMonadicFold' m s' a -> 'IndexPreservingMonadicFold' m (s,s') a -- @ -- -- >>> ("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' {-# INLINE beside #-} -- | Visit the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. -- -- >>> [("hello","world"),("!!!","!!!")]^.. taking 2 (traverse.both) -- ["hello","world"] -- -- >>> timingOut $ [1..] ^.. taking 3 traverse -- [1,2,3] -- -- >>> over (taking 5 traverse) succ "hello world" -- "ifmmp world" -- -- @ -- 'taking' :: 'Int' -> 'Traversal'' s a -> 'Traversal'' s a -- 'taking' :: 'Int' -> 'Lens'' s a -> 'Traversal'' s a -- 'taking' :: 'Int' -> 'Iso'' s a -> 'Traversal'' s a -- 'taking' :: 'Int' -> 'Prism'' s a -> 'Traversal'' s a -- 'taking' :: 'Int' -> 'Getter' s a -> 'Fold' s a -- 'taking' :: 'Int' -> 'Fold' s a -> 'Fold' s a -- 'taking' :: 'Int' -> 'Action' m s a -> 'MonadicFold' m s a -- 'taking' :: 'Int' -> 'MonadicFold' m s a -> 'MonadicFold' m s a -- 'taking' :: 'Int' -> 'IndexedTraversal'' i s a -> 'IndexedTraversal'' i s a -- 'taking' :: 'Int' -> 'IndexedLens'' i s a -> 'IndexedTraversal'' i s a -- 'taking' :: 'Int' -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'taking' :: 'Int' -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'taking' :: 'Int' -> 'IndexedAction' i m s a -> 'IndexedMonadicFold' i m s a -- 'taking' :: 'Int' -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- @ taking :: (Conjoined p, Applicative f) => Int -> Over p (BazaarT p f a a) s t a a -> Over p f s t a a taking n l pafb s = outs b <$> traverse (corep pafb) (take n $ pins b) where b = l sell s {-# INLINE taking #-} -- | Visit all but the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. -- -- >>> ("hello","world") ^? dropping 1 both -- Just "world" -- -- Dropping works on infinite traversals as well: -- -- >>> [1..] ^? dropping 1 folded -- Just 2 -- -- @ -- 'dropping' :: 'Int' -> 'Traversal'' s a -> 'Traversal'' s a -- 'dropping' :: 'Int' -> 'Lens'' s a -> 'Traversal'' s a -- 'dropping' :: 'Int' -> 'Iso'' s a -> 'Traversal'' s a -- 'dropping' :: 'Int' -> 'Prism'' s a -> 'Traversal'' s a -- 'dropping' :: 'Int' -> 'Getter' s a -> 'Fold' s a -- 'dropping' :: 'Int' -> 'Fold' s a -> 'Fold' s a -- 'dropping' :: 'Int' -> 'Action' m s a -> 'MonadicFold' m s a -- 'dropping' :: 'Int' -> 'MonadicFold' m s a -> 'MonadicFold' m s a -- 'dropping' :: 'Int' -> 'IndexedTraversal'' i s a -> 'IndexedTraversal'' i s a -- 'dropping' :: 'Int' -> 'IndexedLens'' i s a -> 'IndexedTraversal'' i s a -- 'dropping' :: 'Int' -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'dropping' :: 'Int' -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'dropping' :: 'Int' -> 'IndexedAction' i m s a -> 'IndexedMonadicFold' i m s a -- 'dropping' :: 'Int' -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- @ dropping :: (Conjoined p, Applicative f) => Int -> Over p (Indexing f) s t a a -> Over p f s t a a dropping n l pafb s = snd $ runIndexing (l paifb s) 0 where paifb = cotabulate $ \wa -> Indexing $ \i -> let i' = i + 1 in i' `seq` (i', if i < n then pure (extract wa) else corep pafb wa) {-# INLINE dropping #-} ------------------------------------------------------------------------------ -- Cloning Traversals ------------------------------------------------------------------------------ -- | A 'Traversal' is completely characterized by its behavior on a 'Bazaar'. -- -- Cloning a 'Traversal' is one way to make sure you aren't given -- something weaker, such as a 'Fold' and can be -- used as a way to pass around traversals that have to be monomorphic in @f@. -- -- Note: This only accepts a proper 'Traversal' (or 'Lens'). To clone a 'Lens' -- as such, use 'Control.Lens.Lens.cloneLens'. -- -- Note: It is usually better to use 'Control.Lens.Reified.ReifiedTraversal' and -- 'Control.Lens.Reified.reflectTraversal' than to 'cloneTraversal'. The -- former can execute at full speed, while the latter needs to round trip through -- the 'Bazaar'. -- -- >>> let foo l a = (view (coerced (cloneTraversal l)) a, set (cloneTraversal l) 10 a) -- >>> foo both ("hello","world") -- ("helloworld",(10,10)) -- -- @ -- 'cloneTraversal' :: 'LensLike' ('Bazaar' (->) a b) s t a b -> 'Traversal' s t a b -- @ cloneTraversal :: ATraversal s t a b -> Traversal s t a b cloneTraversal l f = bazaar f . l sell {-# INLINE cloneTraversal #-} -- | Clone a 'Traversal' yielding an 'IndexPreservingTraversal' that passes through -- whatever index it is composed with. cloneIndexPreservingTraversal :: ATraversal s t a b -> IndexPreservingTraversal s t a b cloneIndexPreservingTraversal l pafb = cotabulate $ \ws -> runBazaar (l sell (extract ws)) $ \a -> corep pafb (a <$ ws) {-# INLINE cloneIndexPreservingTraversal #-} -- | Clone an 'IndexedTraversal' yielding an 'IndexedTraversal' with the same index. cloneIndexedTraversal :: AnIndexedTraversal i s t a b -> IndexedTraversal i s t a b cloneIndexedTraversal l f = bazaar (Indexed (indexed f)) . l sell {-# INLINE cloneIndexedTraversal #-} ------------------------------------------------------------------------------ -- Indexed Traversals ------------------------------------------------------------------------------ -- | Traversal with an index. -- -- /NB:/ When you don't need access to the index then you can just apply your 'IndexedTraversal' -- directly as a function! -- -- @ -- 'itraverseOf' ≡ 'Control.Lens.Indexed.withIndex' -- 'Control.Lens.Traversal.traverseOf' l = 'itraverseOf' l '.' 'const' = 'id' -- @ -- -- @ -- '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 :: (Indexed i a (f b) -> s -> f t) -> (i -> a -> f b) -> s -> f t itraverseOf l = l .# Indexed {-# INLINE itraverseOf #-} -- | Traverse with an index (and the arguments flipped). -- -- @ -- 'Control.Lens.Traversal.forOf' l a ≡ 'iforOf' l a '.' 'const' -- 'iforOf' ≡ 'flip' '.' 'itraverseOf' -- @ -- -- @ -- '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 :: (Indexed i a (f b) -> s -> f t) -> s -> (i -> a -> f b) -> f t iforOf = flip . itraverseOf {-# INLINE iforOf #-} -- | Map each element of a structure targeted by a 'Lens' to a monadic action, -- evaluate these actions from left to right, and collect the results, with access -- its position. -- -- When you don't need access to the index 'mapMOf' is more liberal in what it can accept. -- -- @ -- 'Control.Lens.Traversal.mapMOf' l ≡ 'imapMOf' l '.' 'const' -- @ -- -- @ -- '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 :: (Indexed i a (WrappedMonad m b) -> s -> WrappedMonad m t) -> (i -> a -> m b) -> s -> m t imapMOf l = mapMOf l .# Indexed {-# INLINE imapMOf #-} -- | Map each element of a structure targeted by a 'Lens' to a monadic action, -- evaluate these actions from left to right, and collect the results, with access -- its position (and the arguments flipped). -- -- @ -- 'Control.Lens.Traversal.forMOf' l a ≡ 'iforMOf' l a '.' 'const' -- 'iforMOf' ≡ 'flip' '.' 'imapMOf' -- @ -- -- @ -- 'iforMOf' :: 'Monad' m => 'IndexedLens' i s t a b -> s -> (i -> a -> m b) -> m t -- 'iforMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> s -> (i -> a -> m b) -> m t -- @ iforMOf :: (Indexed i a (WrappedMonad m b) -> s -> WrappedMonad m t) -> s -> (i -> a -> m b) -> m t iforMOf = flip . imapMOf {-# INLINE iforMOf #-} -- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'IndexedTraversal' with access to the index. -- -- 'imapAccumROf' accumulates state from right to left. -- -- @ -- 'Control.Lens.Traversal.mapAccumROf' l ≡ 'imapAccumROf' l '.' 'const' -- @ -- -- @ -- 'imapAccumROf' :: 'IndexedLens' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'imapAccumROf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ imapAccumROf :: Over (Indexed i) (Backwards (State acc)) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) imapAccumROf l = mapAccumROf l .# Indexed {-# INLINE imapAccumROf #-} -- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IndexedTraversal' with access to the index. -- -- 'imapAccumLOf' accumulates state from left to right. -- -- @ -- 'Control.Lens.Traversal.mapAccumLOf' l ≡ 'imapAccumLOf' l '.' 'const' -- @ -- -- @ -- 'imapAccumLOf' :: 'IndexedLens' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'imapAccumLOf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ imapAccumLOf :: Over (Indexed i) (State acc) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) imapAccumLOf l = mapAccumLOf l .# Indexed {-# INLINE imapAccumLOf #-} ------------------------------------------------------------------------------ -- Common Indexed Traversals ------------------------------------------------------------------------------ -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b traversed = conjoined traverse (indexing traverse) {-# INLINE traversed #-} -- | 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) {-# INLINE traversed64 #-} -- | This is the trivial empty 'Traversal'. -- -- @ -- 'ignored' :: 'IndexedTraversal' i s s a b -- @ -- -- @ -- 'ignored' ≡ 'const' 'pure' -- @ -- -- >>> 6 & ignored %~ absurd -- 6 ignored :: Applicative f => pafb -> s -> f s ignored _ = pure {-# INLINE ignored #-} -- | Allows 'IndexedTraversal' the value at the smallest index. class Ord k => TraverseMin k m | m -> k where -- | 'IndexedTraversal' of the element with the smallest index. traverseMin :: IndexedTraversal' k (m v) v instance TraverseMin Int IntMap where traverseMin f m = case IntMap.minViewWithKey m of #if MIN_VERSION_containers(0,5,0) Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const (Just v)) m #else Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const v) m #endif Nothing -> pure m {-# INLINE traverseMin #-} instance Ord k => TraverseMin k (Map k) where traverseMin f m = case Map.minViewWithKey m of Just ((k, a), _) -> indexed f k a <&> \v -> Map.updateMin (const (Just v)) m Nothing -> pure m {-# INLINE traverseMin #-} -- | Allows 'IndexedTraversal' of the value at the largest index. class Ord k => TraverseMax k m | m -> k where -- | 'IndexedTraversal' of the element at the largest index. traverseMax :: IndexedTraversal' k (m v) v instance TraverseMax Int IntMap where traverseMax f m = case IntMap.maxViewWithKey m of #if MIN_VERSION_containers(0,5,0) Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const (Just v)) m #else Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const v) m #endif Nothing -> pure m {-# INLINE traverseMax #-} instance Ord k => TraverseMax k (Map k) where traverseMax f m = case Map.maxViewWithKey m of Just ((k, a), _) -> indexed f k a <&> \v -> Map.updateMax (const (Just v)) m Nothing -> pure m {-# INLINE traverseMax #-} -- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or -- 'Iso' if it exists. -- -- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 -- [[1],[5,4]] -- -- >>> [[1],[3,4]] ^? elementOf (folded.folded) 1 -- Just 3 -- -- >>> timingOut $ ['a'..] ^?! elementOf folded 5 -- 'f' -- -- >>> timingOut $ take 10 $ elementOf traverse 3 .~ 16 $ [0..] -- [0,1,2,16,4,5,6,7,8,9] -- -- @ -- 'elementOf' :: 'Traversal'' s a -> 'Int' -> 'IndexedTraversal'' 'Int' s a -- 'elementOf' :: 'Fold' s a -> 'Int' -> 'IndexedFold' 'Int' s a -- @ elementOf :: Applicative f => LensLike (Indexing f) s t a a -> Int -> IndexedLensLike Int f s t a a elementOf l p = elementsOf l (p ==) {-# INLINE elementOf #-} -- | Traverse the /nth/ element of a 'Traversable' container. -- -- @ -- 'element' ≡ 'elementOf' 'traverse' -- @ element :: Traversable t => Int -> IndexedTraversal' Int (t a) a element = elementOf traverse {-# INLINE element #-} -- | Traverse (or fold) selected elements of a 'Traversal' (or 'Fold') where their ordinal positions match a predicate. -- -- @ -- 'elementsOf' :: 'Traversal'' s a -> ('Int' -> 'Bool') -> 'IndexedTraversal'' 'Int' s a -- 'elementsOf' :: 'Fold' s a -> ('Int' -> 'Bool') -> 'IndexedFold' 'Int' s a -- @ elementsOf :: Applicative f => LensLike (Indexing f) s t a a -> (Int -> Bool) -> IndexedLensLike Int f s t a a elementsOf l p iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, if p i then indexed iafb i a else pure a))) s) 0 {-# INLINE elementsOf #-} -- | Traverse elements of a 'Traversable' container where their ordinal positions matches a predicate. -- -- @ -- 'elements' ≡ 'elementsOf' 'traverse' -- @ elements :: Traversable t => (Int -> Bool) -> IndexedTraversal' Int (t a) a elements = elementsOf traverse {-# INLINE elements #-} -- | Try to map a function over this 'Traversal', failing if the 'Traversal' has no targets. -- -- >>> failover (element 3) (*2) [1,2] :: Maybe [Int] -- Nothing -- -- >>> failover _Left (*2) (Right 4) :: Maybe (Either Int Int) -- Nothing -- -- >>> 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 {-# INLINE failover #-} lens-3.10/src/Control/Lens/Tuple.hs0000644000000000000000000002527612226700613015334 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Tuple -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ------------------------------------------------------------------------------- module Control.Lens.Tuple ( -- * Tuples Field1(..) , Field2(..) , Field3(..) , Field4(..) , Field5(..) , Field6(..) , Field7(..) , Field8(..) , Field9(..) ) where import Control.Applicative import Control.Lens.Combinators import Control.Lens.Indexed import Control.Lens.Type import Data.Functor.Identity -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | Provides access to 1st field of a tuple. class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 1st field of a tuple (and possibly change its type). -- -- >>> (1,2)^._1 -- 1 -- -- >>> _1 .~ "hello" $ (1,2) -- ("hello",2) -- -- >>> (1,2) & _1 .~ "hello" -- ("hello",2) -- -- >>> _1 putStrLn ("hello","world") -- hello -- ((),"world") -- -- This can also be used on larger tuples as well: -- -- >>> (1,2,3,4,5) & _1 +~ 41 -- (42,2,3,4,5) -- -- @ -- '_1' :: 'Lens' (a,b) (a',b) a a' -- '_1' :: 'Lens' (a,b,c) (a',b,c) a a' -- '_1' :: 'Lens' (a,b,c,d) (a',b,c,d) a a' -- ... -- '_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 instance Field1 (Identity a) (Identity b) a b where _1 f (Identity a) = Identity <$> indexed f (0 :: Int) 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# INLINE _1 #-} -- | Provides access to the 2nd field of a tuple. class Field2 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 2nd field of a tuple. -- -- >>> _2 .~ "hello" $ (1,(),3,4) -- (1,"hello",3,4) -- -- >>> (1,2,3,4) & _2 *~ 3 -- (1,6,3,4) -- -- >>> _2 print (1,2) -- 2 -- (1,()) -- -- @ -- 'Control.Lens.Fold.anyOf' '_2' :: (s -> 'Bool') -> (a, s) -> 'Bool' -- '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' 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') {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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 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') {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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 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') {-# 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) {-# 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) {-# 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) {-# 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) {-# 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) {-# 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 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') {-# 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) {-# 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) {-# 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) {-# 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) {-# 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 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') {-# 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) {-# 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) {-# 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) {-# 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 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') {-# 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) {-# 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) {-# 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 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') {-# 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) {-# 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 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') {-# INLINE _9 #-} lens-3.10/src/Control/Lens/Type.hs0000644000000000000000000005231012226700613015151 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE KindSignatures #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Type -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- This module exports the majority of the types that need to appear in user -- signatures or in documentation when talking about lenses. The remaining types -- for consuming lenses are distributed across various modules in the hierarchy. ------------------------------------------------------------------------------- module Control.Lens.Type ( -- * Other Equality, Equality' , Iso, Iso' , Prism , Prism' -- * Lenses, Folds and Traversals , Lens, Lens' , Traversal, Traversal' , Setter, Setter' , Getter, Fold , Action, MonadicFold -- * Indexed , IndexedLens, IndexedLens' , IndexedTraversal, IndexedTraversal' , IndexedSetter, IndexedSetter' , IndexedGetter, IndexedFold , IndexedAction, IndexedMonadicFold -- * Index-Preserving , IndexPreservingLens, IndexPreservingLens' , IndexPreservingTraversal, IndexPreservingTraversal' , IndexPreservingSetter, IndexPreservingSetter' , IndexPreservingGetter, IndexPreservingFold , IndexPreservingAction, IndexPreservingMonadicFold -- * Common , Simple , LensLike, LensLike' , Over, Over' , IndexedLensLike, IndexedLensLike' , Overloading, Overloading' , Overloaded, Overloaded' ) where import Control.Applicative import Control.Lens.Internal.Action import Control.Lens.Internal.Setter import Control.Lens.Internal.Indexed import Data.Functor.Contravariant import Data.Profunctor -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h -- >>> let getter :: Expr -> Expr; getter = fun "getter" -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> import Numeric.Natural -- >>> let nat :: Prism' Integer Natural; nat = prism toInteger $ \i -> if i < 0 then Left i else Right (fromInteger i) ------------------------------------------------------------------------------- -- Lenses ------------------------------------------------------------------------------- -- | A 'Lens' is actually a lens family as described in -- . -- -- With great power comes great responsibility and a 'Lens' is subject to the -- three common sense 'Lens' laws: -- -- 1) You get back what you put in: -- -- @ -- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l b a) ≡ b -- @ -- -- 2) Putting back what you got doesn't change anything: -- -- @ -- 'Control.Lens.Setter.set' l ('Control.Lens.Getter.view' l a) a ≡ a -- @ -- -- 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 -- @ -- -- These laws are strong enough that the 4 type parameters of a 'Lens' cannot -- vary fully independently. For more on how they interact, read the \"Why is -- it a Lens Family?\" section of -- . -- -- 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'. -- -- Since every 'Lens' is a valid 'Traversal', the -- 'Traversal' laws are required of any 'Lens' you create: -- -- @ -- l 'pure' ≡ 'pure' -- 'fmap' (l f) '.' l g ≡ 'Data.Functor.Compose.getCompose' '.' l ('Data.Functor.Compose.Compose' '.' 'fmap' f '.' g) -- @ -- -- @ -- type 'Lens' s t a b = forall f. 'Functor' f => 'LensLike' f s t a b -- @ type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -- | @ -- type 'Lens'' = 'Simple' 'Lens' -- @ type Lens' s a = Lens s s a a -- | Every 'IndexedLens' is a valid 'Lens' and a valid 'Control.Lens.Traversal.IndexedTraversal'. type IndexedLens i s t a b = forall f p. (Indexable i p, Functor f) => p a (f b) -> s -> f t -- | @ -- type 'IndexedLens'' i = 'Simple' ('IndexedLens' i) -- @ type IndexedLens' i s a = IndexedLens i s s a a -- | An 'IndexPreservingLens' leaves any index it is composed with alone. type IndexPreservingLens s t a b = forall p f. (Conjoined p, Functor f) => p a (f b) -> p s (f t) -- | @ -- type 'IndexPreservingLens'' = 'Simple' 'IndexPreservingLens' -- @ type IndexPreservingLens' s a = IndexPreservingLens s s a a ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------ -- | A 'Traversal' can be used directly as a 'Control.Lens.Setter.Setter' or a 'Fold' (but not as a 'Lens') and provides -- the ability to both read and update multiple fields, subject to some relatively weak 'Traversal' laws. -- -- These have also been known as multilenses, but they have the signature and spirit of -- -- @ -- 'Data.Traversable.traverse' :: 'Data.Traversable.Traversable' f => 'Traversal' (f a) (f b) a b -- @ -- -- and the more evocative name suggests their application. -- -- Most of the time the 'Traversal' you will want to use is just 'Data.Traversable.traverse', but you can also pass any -- 'Lens' or 'Iso' as a 'Traversal', and composition of a 'Traversal' (or 'Lens' or 'Iso') with a 'Traversal' (or 'Lens' or 'Iso') -- using ('.') forms a valid 'Traversal'. -- -- The laws for a 'Traversal' @t@ follow from the laws for 'Data.Traversable.Traversable' as stated in \"The Essence of the Iterator Pattern\". -- -- @ -- t 'pure' ≡ 'pure' -- 'fmap' (t f) '.' t g ≡ 'Data.Functor.Compose.getCompose' '.' t ('Data.Functor.Compose.Compose' '.' 'fmap' f '.' g) -- @ -- -- One consequence of this requirement is that a 'Traversal' needs to leave the same number of elements as a -- candidate for subsequent 'Traversal' that it started with. Another testament to the strength of these laws -- is that the caveat expressed in section 5.5 of the \"Essence of the Iterator Pattern\" about exotic -- 'Data.Traversable.Traversable' instances that 'Data.Traversable.traverse' the same entry multiple times was actually already ruled out by the -- second law in that same paper! type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t -- | @ -- type 'Traversal'' = 'Simple' 'Traversal' -- @ type Traversal' s a = Traversal s s a a -- | Every 'IndexedTraversal' is a valid 'Control.Lens.Traversal.Traversal' or -- 'Control.Lens.Fold.IndexedFold'. -- -- The 'Indexed' constraint is used to allow an 'IndexedTraversal' to be used -- directly as a 'Control.Lens.Traversal.Traversal'. -- -- The 'Control.Lens.Traversal.Traversal' laws are still required to hold. type IndexedTraversal i s t a b = forall p f. (Indexable i p, Applicative f) => p a (f b) -> s -> f t -- | @ -- type 'IndexedTraversal'' i = 'Simple' ('IndexedTraversal' i) -- @ type IndexedTraversal' i s a = IndexedTraversal 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) -- | @ -- type 'IndexPreservingTraversal'' = 'Simple' 'IndexPreservingTraversal' -- @ type IndexPreservingTraversal' s a = IndexPreservingTraversal s s a a ------------------------------------------------------------------------------ -- Setters ------------------------------------------------------------------------------ -- | The only 'LensLike' law that can apply to a 'Setter' @l@ is that -- -- @ -- 'Control.Lens.Setter.set' l y ('Control.Lens.Setter.set' l x a) ≡ 'Control.Lens.Setter.set' l y a -- @ -- -- You can't 'Control.Lens.Getter.view' a 'Setter' in general, so the other two laws are irrelevant. -- -- However, two 'Functor' laws apply to a 'Setter': -- -- @ -- 'Control.Lens.Setter.over' l 'id' ≡ 'id' -- 'Control.Lens.Setter.over' l f '.' 'Control.Lens.Setter.over' l g ≡ 'Control.Lens.Setter.over' l (f '.' g) -- @ -- -- These can be stated more directly: -- -- @ -- l 'pure' ≡ 'pure' -- l f '.' 'untainted' '.' l g ≡ l (f '.' 'untainted' '.' g) -- @ -- -- You can compose a 'Setter' with a 'Lens' or a 'Traversal' using ('.') from the @Prelude@ -- and the result is always only a 'Setter' and nothing more. -- -- >>> over traverse f [a,b,c,d] -- [f a,f b,f c,f d] -- -- >>> over _1 f (a,b) -- (f a,b) -- -- >>> over (traverse._1) f [(a,b),(c,d)] -- [(f a,b),(f c,d)] -- -- >>> over both f (a,b) -- (f a,f b) -- -- >>> over (traverse.both) f [(a,b),(c,d)] -- [(f a,f b),(f c,f d)] type Setter s t a b = forall f. Settable f => (a -> f b) -> s -> f t -- | A 'Setter'' is just a 'Setter' that doesn't change the types. -- -- These are particularly common when talking about monomorphic containers. /e.g./ -- -- @ -- 'sets' Data.Text.map :: 'Setter'' 'Data.Text.Internal.Text' 'Char' -- @ -- -- @ -- type 'Setter'' = 'Setter'' -- @ type Setter' s a = Setter s s a a -- | Every 'IndexedSetter' is a valid 'Setter'. -- -- The 'Setter' laws are still required to hold. type IndexedSetter i s t a b = forall f p. (Indexable i p, Settable f) => p a (f b) -> s -> f t -- | @ -- type 'IndexedSetter'' i = 'Simple' ('IndexedSetter' i) -- @ type IndexedSetter' i s a = IndexedSetter i s s a a -- | An 'IndexPreservingSetter' can be composed with a 'IndexedSetter', 'IndexedTraversal' or 'IndexedLens' -- and leaves the index intact, yielding an 'IndexedSetter'. type IndexPreservingSetter s t a b = forall p f. (Conjoined p, Settable f) => p a (f b) -> p s (f t) -- | @ -- type 'IndexedPreservingSetter'' i = 'Simple' 'IndexedPreservingSetter' -- @ type IndexPreservingSetter' s a = IndexPreservingSetter s s a a ----------------------------------------------------------------------------- -- Isomorphisms ----------------------------------------------------------------------------- -- | Isomorphism families can be composed with another 'Lens' using ('.') and 'id'. -- -- Note: Composition with an 'Iso' is index- and measure- preserving. type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- | @ -- type 'Iso'' = 'Control.Lens.Type.Simple' 'Iso' -- @ type Iso' s a = Iso s s a a ------------------------------------------------------------------------------ -- Prism Internals ------------------------------------------------------------------------------ -- | A 'Prism' @l@ is a 0-or-1 target 'Traversal' that can also be turned -- around with 'Control.Lens.Review.re' to obtain a 'Getter' in the -- opposite direction. -- -- There are two laws that a 'Prism' should satisfy: -- -- First, if I 'Control.Lens.Review.re' or 'Control.Lens.Prism.review' a value with a 'Prism' and then 'Control.Lens.Fold.preview' or use ('Control.Lens.Fold.^?'), I will get it back: -- -- @ -- 'Control.Lens.Fold.preview' l ('Control.Lens.Prism.review' l b) ≡ 'Just' b -- @ -- -- Second, if you can extract a value @a@ using a 'Prism' @l@ from a value @s@, then the value @s@ is completely described my @l@ and @a@: -- -- If @'Control.Lens.Fold.preview' l s ≡ 'Just' a@ then @'Control.Lens.Prism.review' l a ≡ s@ -- -- These two laws imply that the 'Traversal' laws hold for every 'Prism' and that we 'Data.Traversable.traverse' at most 1 element: -- -- @ -- 'Control.Lens.Fold.lengthOf' l x '<=' 1 -- @ -- -- It may help to think of this as a 'Iso' that can be partial in one direction. -- -- Every 'Prism' is a valid 'Traversal'. -- -- Every 'Iso' is a valid 'Prism'. -- -- For example, you might have a @'Prism'' 'Integer' 'Numeric.Natural.Natural'@ allows you to always -- go from a 'Numeric.Natural.Natural' to an 'Integer', and provide you with tools to check if an 'Integer' is -- a 'Numeric.Natural.Natural' and/or to edit one if it is. -- -- -- @ -- 'nat' :: 'Prism'' 'Integer' 'Numeric.Natural.Natural' -- 'nat' = 'Control.Lens.Prism.prism' 'toInteger' '$' \\ i -> -- if i '<' 0 -- then 'Left' i -- else 'Right' ('fromInteger' i) -- @ -- -- Now we can ask if an 'Integer' is a 'Numeric.Natural.Natural'. -- -- >>> 5^?nat -- Just 5 -- -- >>> (-5)^?nat -- Nothing -- -- We can update the ones that are: -- -- >>> (-3,4) & both.nat *~ 2 -- (-3,8) -- -- And we can then convert from a 'Numeric.Natural.Natural' to an 'Integer'. -- -- >>> 5 ^. re nat -- :: Natural -- 5 -- -- Similarly we can use a 'Prism' to 'Data.Traversable.traverse' the 'Left' half of an 'Either': -- -- >>> Left "hello" & _Left %~ length -- Left 5 -- -- or to construct an 'Either': -- -- >>> 5^.re _Left -- Left 5 -- -- such that if you query it with the 'Prism', you will get your original input back. -- -- >>> 5^.re _Left ^? _Left -- Just 5 -- -- Another interesting way to think of a 'Prism' is as the categorical dual of a 'Lens' -- -- a co-'Lens', so to speak. This is what permits the construction of 'Control.Lens.Prism.outside'. -- -- Note: Composition with a 'Prism' is index-preserving. type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) -- | A 'Simple' 'Prism'. type Prism' s a = Prism s s a a ------------------------------------------------------------------------------- -- Equality ------------------------------------------------------------------------------- -- | A witness that @(a ~ s, b ~ t)@. -- -- Note: Composition with an 'Equality' is index-preserving. type Equality s t a b = forall p (f :: * -> *). p a (f b) -> p s (f t) -- | A 'Simple' 'Equality'. type Equality' s a = Equality s s a a ------------------------------------------------------------------------------- -- Getters ------------------------------------------------------------------------------- -- | A 'Getter' describes how to retrieve a single value in a way that can be -- composed with other 'LensLike' constructions. -- -- 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)@. -- -- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold', -- since it just ignores the 'Applicative'. type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s -- | Every 'IndexedGetter' is a valid 'Control.Lens.Fold.IndexedFold' and can be used for 'Control.Lens.Getter.Getting' like a 'Getter'. type IndexedGetter i s a = forall p f. (Indexable i p, Contravariant f, Functor f) => p a (f a) -> s -> f s -- | An 'IndexPreservingGetter' can be used as a 'Getter', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold', 'IndexedFold' or 'IndexedGetter' respectively. type IndexPreservingGetter s a = forall p f. (Conjoined p, Contravariant f, Functor f) => p a (f a) -> p s (f s) -------------------------- -- Folds -------------------------- -- | A 'Fold' describes how to retrieve multiple values in a way that can be composed -- with other 'LensLike' constructions. -- -- A @'Fold' s a@ provides a structure with operations very similar to those of the 'Data.Foldable.Foldable' -- typeclass, see 'Control.Lens.Fold.foldMapOf' and the other 'Fold' combinators. -- -- By convention, if there exists a 'foo' method that expects a @'Data.Foldable.Foldable' (f a)@, then there should be a -- @fooOf@ method that takes a @'Fold' s a@ and a value of type @s@. -- -- A 'Getter' is a legal 'Fold' that just ignores the supplied 'Data.Monoid.Monoid'. -- -- Unlike a 'Control.Lens.Traversal.Traversal' a 'Fold' is read-only. Since a 'Fold' cannot be used to write back -- there are no 'Lens' laws that apply. type Fold s a = forall f. (Contravariant f, Applicative f) => (a -> f a) -> s -> f s -- | Every 'IndexedFold' is a valid 'Control.Lens.Fold.Fold' and can be used for 'Control.Lens.Getter.Getting'. type IndexedFold i s a = forall p f. (Indexable i p, Contravariant f, Applicative 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 IndexPreservingFold s a = forall p f. (Conjoined p, Contravariant f, Applicative f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- -- Actions ------------------------------------------------------------------------------- -- | An 'Action' is a 'Getter' enriched with access to a 'Monad' for side-effects. -- -- Every 'Getter' can be used as an 'Action'. -- -- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. type Action m s a = forall f r. Effective m r f => (a -> f a) -> s -> f s -- | An 'IndexedAction' is an 'IndexedGetter' enriched with access to a 'Monad' for side-effects. -- -- Every 'Getter' can be used as an 'Action'. -- -- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. type IndexedAction i m s a = forall p f r. (Indexable i p, Effective m r f) => p a (f a) -> s -> f s -- | An 'IndexPreservingAction' can be used as a 'Action', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedMonadicFold', 'IndexedMonadicFold' or 'IndexedAction' respectively. type IndexPreservingAction m s a = forall p f r. (Conjoined p, Effective m r f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- -- MonadicFolds ------------------------------------------------------------------------------- -- | A 'MonadicFold' is a 'Fold' enriched with access to a 'Monad' for side-effects. -- -- Every 'Fold' can be used as a 'MonadicFold', that simply ignores the access to the 'Monad'. -- -- 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 -- | An 'IndexedMonadicFold' is an 'IndexedFold' enriched with access to a 'Monad' for side-effects. -- -- Every 'IndexedFold' can be used as an 'IndexedMonadicFold', that simply ignores the access to the 'Monad'. -- -- 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 -- | 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) ------------------------------------------------------------------------------- -- Simple Overloading ------------------------------------------------------------------------------- -- | A 'Simple' 'Lens', 'Simple' 'Traversal', ... can -- be used instead of a 'Lens','Traversal', ... -- whenever the type variables don't change upon setting a value. -- -- @ -- 'Data.Complex.Lens._imagPart' :: 'Simple' 'Lens' ('Data.Complex.Complex' a) a -- 'Control.Lens.Traversal.traversed' :: 'Simple' ('IndexedTraversal' 'Int') [a] a -- @ -- -- Note: To use this alias in your own code with @'LensLike' f@ or -- 'Setter', you may have to turn on @LiberalTypeSynonyms@. -- -- 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 -- @ type Overloading p q f s t a b = p a (f b) -> q s (f t) -- | @ -- type 'Overloading'' p q f s a = 'Simple' ('Overloading' p q f) s a -- @ type Overloading' p q f s a = Overloading p q f s s a a -- | @ -- type 'LensLike' f s t a b = 'Overloaded' (->) f s t a b -- @ type Overloaded p f s t a b = p a (f b) -> p s (f t) -- | @ -- type 'Overloaded'' p q f s a = 'Simple' ('Overloaded' p q f) s a -- @ type Overloaded' p f s a = Overloaded p f s s a a -- | Many combinators that accept a 'Lens' can also accept a -- 'Traversal' in limited situations. -- -- They do so by specializing the type of 'Functor' that they require of the -- caller. -- -- If a function accepts a @'LensLike' f s t a b@ for some 'Functor' @f@, -- then they may be passed a 'Lens'. -- -- Further, if @f@ is an 'Applicative', they may also be passed a -- 'Traversal'. type LensLike f s t a b = (a -> f b) -> s -> f t -- | @ -- type 'LensLike'' f = 'Simple' ('LensLike' f) -- @ type LensLike' f s a = LensLike f s s a a -- | Convenient alias for constructing indexed lenses and their ilk. type IndexedLensLike i f s t a b = forall p. Indexable i p => p a (f b) -> s -> f t -- | Convenient alias for constructing simple indexed lenses and their ilk. type IndexedLensLike' i f s a = IndexedLensLike i f s s a a -- | This is a convenient alias for use when you need to consume either indexed or non-indexed lens-likes based on context. type Over p f s t a b = p a (f b) -> s -> f t -- | This is a convenient alias for use when you need to consume either indexed or non-indexed lens-likes based on context. -- -- @ -- type 'Over'' p f = 'Simple' ('Over' p f) -- @ type Over' p f s a = Over p f s s a a lens-3.10/src/Control/Lens/Wrapped.hs0000644000000000000000000004161412226700613015637 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Wrapped -- Copyright : (C) 2012-13 Edward Kmett, Michael Sloan -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2, MPTCs, fundeps -- -- The 'Wrapped' class provides similar functionality as @Control.Newtype@, -- from the @newtype@ package, but in a more convenient and efficient form. -- -- There are a few functions from @newtype@ that are not provided here, because -- they can be done with the 'Iso' directly: -- -- @ -- Control.Newtype.over 'Sum' f ≡ 'wrapping' 'Sum' '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 -- @ -- -- 'under' can also be used with 'wrapping' to provide the equivalent of -- @Control.Newtype.under@. Also, most use cases don't need full polymorphism, -- so only the single constructor 'wrapping' functions would be needed. -- -- These equivalences aren't 100% honest, because @newtype@'s operators -- need to rely on two @Newtype@ constraints. This means that the wrapper used -- for the output is not necessarily the same as the input. -- ---------------------------------------------------------------------------- module Control.Lens.Wrapped ( Wrapped(..) , unwrapped , wrapped', unwrapped' , wrapping, unwrapping , wrappings, unwrappings , op , ala, alaf ) where import Control.Applicative import Control.Arrow import Control.Applicative.Backwards import Control.Comonad.Trans.Traced import Control.Exception import Control.Lens.Internal.Review import Control.Lens.Iso import Control.Lens.Review import Control.Monad.Trans.Cont import Control.Monad.Trans.Error import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Foldable as Foldable import Data.Functor.Compose import Data.Functor.Contravariant import qualified Data.Functor.Contravariant.Compose as Contravariant import Data.Functor.Constant import Data.Functor.Coproduct import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable import Data.IntSet as IntSet import Data.IntMap as IntMap import Data.HashSet as HashSet import Data.HashMap.Lazy as HashMap import Data.Map as Map import Data.Monoid import Data.Sequence as Seq hiding (length) import Data.Set as Set import Data.Tagged -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | 'Wrapped' provides isomorphisms to wrap and unwrap newtypes or -- data types with one constructor. class Wrapped s t a b | a -> s, b -> t, a t -> s, b s -> t where -- | An isomorphism between s and @a@ and a related one between @t@ and @b@, such that when @a = b@, @s = t@. -- -- This is often used via 'wrapping' to aid type inference. wrapped :: Iso s t a b -- * base instance Wrapped Bool Bool All All where wrapped = iso All getAll {-# INLINE wrapped #-} instance Wrapped Bool Bool Any Any where wrapped = iso Any getAny {-# INLINE wrapped #-} instance Wrapped a b (Sum a) (Sum b) where wrapped = iso Sum getSum {-# INLINE wrapped #-} instance Wrapped a b (Product a) (Product b) where wrapped = iso Product getProduct {-# INLINE wrapped #-} instance Wrapped (a -> m b) (u -> n v) (Kleisli m a b) (Kleisli n u v) where wrapped = iso Kleisli runKleisli {-# INLINE wrapped #-} instance Wrapped (m a) (n b) (WrappedMonad m a) (WrappedMonad n b) where wrapped = iso WrapMonad unwrapMonad {-# INLINE wrapped #-} instance Wrapped (a b c) (u v w) (WrappedArrow a b c) (WrappedArrow u v w) where wrapped = iso WrapArrow unwrapArrow {-# INLINE wrapped #-} instance Wrapped [a] [b] (ZipList a) (ZipList b) where wrapped = iso ZipList getZipList {-# INLINE wrapped #-} instance Wrapped a b (Const a x) (Const b y) where wrapped = iso Const getConst {-# INLINE wrapped #-} instance Wrapped a b (Dual a) (Dual b) where wrapped = iso Dual getDual {-# INLINE wrapped #-} instance Wrapped (a -> a) (b -> b) (Endo a) (Endo b) where wrapped = iso Endo appEndo {-# INLINE wrapped #-} instance Wrapped (Maybe a) (Maybe b) (First a) (First b) where wrapped = iso First getFirst {-# INLINE wrapped #-} instance Wrapped (Maybe a) (Maybe b) (Last a) (Last b) where wrapped = iso Last getLast {-# INLINE wrapped #-} instance (ArrowApply m, ArrowApply n) => Wrapped (m () a) (n () b) (ArrowMonad m a) (ArrowMonad n b) where wrapped = iso ArrowMonad getArrowMonad {-# INLINE wrapped #-} -- * lens instance Wrapped a b (Reviewed s a) (Reviewed t b) where wrapped = iso Reviewed runReviewed {-# INLINE wrapped #-} -- * transformers instance Wrapped (f a) (f' a') (Backwards f a) (Backwards f' a') where wrapped = iso Backwards forwards {-# INLINE wrapped #-} instance Wrapped (f (g a)) (f' (g' a')) (Compose f g a) (Compose f' g' a') where wrapped = iso Compose getCompose {-# INLINE wrapped #-} instance Wrapped a a' (Constant a b) (Constant a' b') where wrapped = iso Constant getConstant {-# INLINE wrapped #-} instance Wrapped ((a -> m r) -> m r) ((a' -> m' r') -> m' r') (ContT r m a) (ContT r' m' a') where wrapped = iso ContT runContT {-# INLINE wrapped #-} instance Wrapped (m (Either e a)) (m' (Either e' a')) (ErrorT e m a) (ErrorT e' m' a') where wrapped = iso ErrorT runErrorT {-# INLINE wrapped #-} instance Wrapped a a' (Identity a) (Identity a') where wrapped = iso Identity runIdentity {-# INLINE wrapped #-} instance Wrapped (m a) (m' a') (IdentityT m a) (IdentityT m' a') where wrapped = iso IdentityT runIdentityT {-# INLINE wrapped #-} instance Wrapped (m [a]) (m' [a']) (ListT m a) (ListT m' a') where wrapped = iso ListT runListT {-# INLINE wrapped #-} instance Wrapped (m (Maybe a)) (m' (Maybe a')) (MaybeT m a) (MaybeT m' a') where wrapped = iso MaybeT runMaybeT {-# INLINE wrapped #-} instance Wrapped (r -> m a) (r' -> m' a') (ReaderT r m a) (ReaderT r' m' a') where wrapped = iso ReaderT runReaderT {-# INLINE wrapped #-} instance Wrapped (f a) (f' a') (Reverse f a) (Reverse f' a') where wrapped = iso Reverse getReverse {-# INLINE wrapped #-} instance Wrapped (r -> s -> m (a, s, w)) (r' -> s' -> m' (a', s', w')) (Lazy.RWST r w s m a) (Lazy.RWST r' w' s' m' a') where wrapped = iso Lazy.RWST Lazy.runRWST {-# INLINE wrapped #-} instance Wrapped (r -> s -> m (a, s, w)) (r' -> s' -> m' (a', s', w')) (Strict.RWST r w s m a) (Strict.RWST r' w' s' m' a') where wrapped = iso Strict.RWST Strict.runRWST {-# INLINE wrapped #-} instance Wrapped (s -> m (a, s)) (s' -> m' (a', s')) (Lazy.StateT s m a) (Lazy.StateT s' m' a') where wrapped = iso Lazy.StateT Lazy.runStateT {-# INLINE wrapped #-} instance Wrapped (s -> m (a, s)) (s' -> m' (a', s')) (Strict.StateT s m a) (Strict.StateT s' m' a') where wrapped = iso Strict.StateT Strict.runStateT {-# INLINE wrapped #-} instance Wrapped (m (a, w)) (m' (a', w')) (Lazy.WriterT w m a) (Lazy.WriterT w' m' a') where wrapped = iso Lazy.WriterT Lazy.runWriterT {-# INLINE wrapped #-} instance Wrapped (m (a, w)) (m' (a', w')) (Strict.WriterT w m a) (Strict.WriterT w' m' a') where wrapped = iso Strict.WriterT Strict.runWriterT {-# INLINE wrapped #-} -- * comonad-transformers instance Wrapped (Either (f a) (g a)) (Either (f' a') (g' a')) (Coproduct f g a) (Coproduct f' g' a') where wrapped = iso Coproduct getCoproduct {-# INLINE wrapped #-} instance Wrapped (w (m -> a)) (w' (m' -> a')) (TracedT m w a) (TracedT m' w' a') where wrapped = iso TracedT runTracedT {-# INLINE wrapped #-} -- * unordered-containers -- | Use @'wrapping' 'HashMap.fromList'@. Unwrapping returns some permutation of the list. instance (Hashable k, Eq k, Hashable k', Eq k') => Wrapped [(k, a)] [(k', b)] (HashMap k a) (HashMap k' b) where wrapped = iso HashMap.fromList HashMap.toList {-# 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 #-} -- * 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 #-} -- | Use @'wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list. instance Wrapped [Int] [Int] IntSet IntSet where wrapped = iso IntSet.fromList IntSet.toAscList {-# 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 #-} -- | 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 Wrapped [a] [b] (Seq a) (Seq b) where wrapped = iso Seq.fromList Foldable.toList {-# INLINE wrapped #-} -- * contravariant instance Wrapped (a -> Bool) (a' -> Bool) (Predicate a) (Predicate a') where wrapped = iso Predicate getPredicate {-# INLINE wrapped #-} instance Wrapped (a -> a -> Ordering) (a' -> a' -> Ordering) (Comparison a) (Comparison a') where wrapped = iso Comparison getComparison {-# INLINE wrapped #-} instance Wrapped (a -> a -> Bool) (a' -> a' -> Bool) (Equivalence a) (Equivalence a') where wrapped = iso Equivalence getEquivalence {-# INLINE wrapped #-} instance Wrapped (b -> a) (b' -> a') (Op a b) (Op a' b') where wrapped = iso Op getOp {-# 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 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 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 #-} -- * tagged instance Wrapped a b (Tagged s a) (Tagged t b) where wrapped = iso Tagged unTagged {-# INLINE wrapped #-} -- * Control.Exception instance Wrapped String String AssertionFailed AssertionFailed where wrapped = iso AssertionFailed failedAssertion {-# INLINE wrapped #-} instance Wrapped String String NoMethodError NoMethodError where wrapped = iso NoMethodError getNoMethodError {-# INLINE wrapped #-} instance Wrapped String String PatternMatchFail PatternMatchFail where wrapped = iso PatternMatchFail getPatternMatchFail {-# INLINE wrapped #-} instance Wrapped String String RecConError RecConError where wrapped = iso RecConError getRecConError {-# INLINE wrapped #-} instance Wrapped String String RecSelError RecSelError where wrapped = iso RecSelError getRecSelError {-# INLINE wrapped #-} instance Wrapped String String RecUpdError RecUpdError where wrapped = iso RecUpdError getRecUpdError {-# INLINE wrapped #-} instance Wrapped String String ErrorCall ErrorCall where wrapped = iso ErrorCall getErrorCall {-# INLINE wrapped #-} getErrorCall :: ErrorCall -> String getErrorCall (ErrorCall x) = x {-# INLINE getErrorCall #-} getRecUpdError :: RecUpdError -> String getRecUpdError (RecUpdError x) = x {-# INLINE getRecUpdError #-} getRecSelError :: RecSelError -> String getRecSelError (RecSelError x) = x {-# INLINE getRecSelError #-} getRecConError :: RecConError -> String getRecConError (RecConError x) = x {-# INLINE getRecConError #-} getPatternMatchFail :: PatternMatchFail -> String getPatternMatchFail (PatternMatchFail x) = x {-# INLINE getPatternMatchFail #-} getNoMethodError :: NoMethodError -> String getNoMethodError (NoMethodError x) = x {-# INLINE getNoMethodError #-} failedAssertion :: AssertionFailed -> String failedAssertion (AssertionFailed x) = x {-# INLINE failedAssertion #-} getArrowMonad :: ArrowApply m => ArrowMonad m a -> m () a getArrowMonad (ArrowMonad x) = x {-# INLINE getArrowMonad #-} -- | Given the constructor for a 'Wrapped' type, return a -- deconstructor that is its inverse. -- -- Assuming the 'Wrapped' instance is legal, these laws hold: -- -- @ -- 'op' f '.' f ≡ 'id' -- f '.' 'op' f ≡ 'id' -- @ -- -- -- >>> op Identity (Identity 4) -- 4 -- -- >>> op Const (Const "hello") -- "hello" op :: Wrapped s s a a => (s -> a) -> a -> s op f = review (wrapping f) {-# INLINE op #-} -- | This is a convenient alias for @'from' 'wrapped'@. -- -- >>> Const "hello" & unwrapped %~ length & getConst -- 5 unwrapped :: Wrapped t s b a => Iso a b s t unwrapped = from wrapped {-# INLINE unwrapped #-} -- | 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. -- -- The user supplied function is /ignored/, merely its type is used. wrapping :: Wrapped s s a a => (s -> a) -> Iso s s a a wrapping _ = wrapped {-# INLINE wrapping #-} -- | This is a convenient version of 'unwrapped' with an argument that's ignored. -- -- The argument is used to specify which newtype the user intends to /remove/ -- by using the constructor for that newtype. -- -- The user supplied function is /ignored/, merely its type is used. unwrapping :: Wrapped s s a a => (s -> a) -> Iso a a s s unwrapping _ = unwrapped {-# INLINE unwrapping #-} -- | This is a convenient version of 'wrapped' with two arguments that are ignored. -- -- These arguments are used to which newtype the user intends to wrap and -- should both be the same constructor. This redundancy is necessary -- in order to find the full polymorphic isomorphism family. -- -- The user supplied functions are /ignored/, merely their types are used. wrappings :: Wrapped s t a b => (s -> a) -> (t -> b) -> Iso s t a b wrappings _ _ = wrapped {-# INLINE wrappings #-} -- | This is a convenient version of 'unwrapped' with two arguments that are ignored. -- -- These arguments are used to which newtype the user intends to remove and -- should both be the same constructor. This redundancy is necessary -- in order to find the full polymorphic isomorphism family. -- -- The user supplied functions are /ignored/, merely their types are used. unwrappings :: Wrapped t s b a => (s -> a) -> (t -> b) -> Iso a b s t unwrappings _ _ = unwrapped {-# INLINE unwrappings #-} -- | This combinator is based on @ala@ from Conor McBride's work on Epigram. -- -- As with 'wrapping', the user supplied function for the newtype is /ignored/. -- -- >>> ala Sum foldMap [1,2,3,4] -- 10 -- -- >>> ala All foldMap [True,True] -- True -- -- >>> ala All foldMap [True,False] -- False -- -- >>> ala Any foldMap [False,False] -- False -- -- >>> ala Any foldMap [True,False] -- True -- -- >>> ala Sum foldMap [1,2,3,4] -- 10 -- -- >>> ala Product foldMap [1,2,3,4] -- 24 ala :: Wrapped s s a a => (s -> a) -> ((s -> a) -> e -> a) -> e -> s ala = au . wrapping {-# INLINE ala #-} -- | This combinator is based on @ala'@ from Conor McBride's work on Epigram. -- -- As with 'wrapping', the user supplied function for the newtype is /ignored/. -- -- >>> alaf Sum foldMap length ["hello","world"] -- 10 alaf :: Wrapped s s a a => (s -> a) -> ((r -> a) -> e -> a) -> (r -> s) -> e -> s alaf = auf . wrapping {-# INLINE alaf #-} lens-3.10/src/Control/Lens/Zipper.hs0000644000000000000000000000560112226700613015502 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Zipper -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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 lens-3.10/src/Control/Lens/Zoom.hs0000644000000000000000000002045412226700613015160 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Zoom -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ------------------------------------------------------------------------------- module Control.Lens.Zoom ( Magnify(..) , Zoom(..) ) where import Control.Lens.Getter import Control.Lens.Internal.Action import Control.Lens.Internal.Zoom import Control.Lens.Type import Control.Monad import Control.Monad.Reader as Reader import Control.Monad.State as State import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Error import Control.Monad.Trans.List import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Data.Monoid import Data.Profunctor.Unsafe -- $setup -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> let f :: Expr -> Expr; f = Vars.f -- >>> let g :: Expr -> Expr; g = Vars.g -- >>> let h :: Expr -> Expr -> Expr; h = Vars.h -- Chosen so that they have lower fixity than ('%='), and to match ('<~'). infixr 2 `zoom`, `magnify` -- | This class allows us to use 'zoom' in, changing the 'State' supplied by -- many different 'Control.Monad.Monad' transformers, potentially quite -- deep in a 'Monad' transformer stack. class (Zoomed m ~ Zoomed n, MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where -- | Run a monadic action in a larger 'State' than it was defined in, -- using a 'Lens'' or 'Control.Lens.Traversal.Traversal''. -- -- This is commonly used to lift actions in a simpler 'State' -- 'Monad' into a 'State' 'Monad' with a larger 'State' type. -- -- When applied to a 'Simple' 'Control.Lens.Traversal.Traversal' over -- multiple values, the actions for each target are executed sequentially -- and the results are aggregated. -- -- This can be used to edit pretty much any 'Monad' transformer stack with a 'State' in it! -- -- >>> flip State.evalState (a,b) $ zoom _1 $ use id -- a -- -- >>> flip State.execState (a,b) $ zoom _1 $ id .= c -- (c,b) -- -- >>> flip State.execState [(a,b),(c,d)] $ zoom traverse $ _2 %= f -- [(a,f b),(c,f d)] -- -- >>> flip State.runState [(a,b),(c,d)] $ zoom traverse $ _2 <%= f -- (f b <> f d <> mempty,[(a,f b),(c,f d)]) -- -- >>> flip State.evalState (a,b) $ zoom both (use id) -- a <> b -- -- @ -- 'zoom' :: 'Monad' m => 'Lens'' s t -> 'StateT' t m a -> 'StateT' s m a -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'StateT' t m c -> 'StateT' s m c -- 'zoom' :: ('Monad' m, 'Monoid' w) => 'Lens'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Error' e) => 'Lens'' s t -> 'ErrorT' e ('RWST' r w t m) c -> 'ErrorT' e ('RWST' r w s m) c -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Monoid' c, 'Error' e) => 'Control.Lens.Traversal.Traversal'' s t -> 'ErrorT' e ('RWST' r w t m) c -> 'ErrorT' e ('RWST' r w s m) c -- ... -- @ zoom :: LensLike' (Zoomed m c) t s -> m c -> n c instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) s t where zoom l (Strict.StateT m) = Strict.StateT $ unfocusing #. l (Focusing #. m) {-# INLINE zoom #-} instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) s t where zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing #. l (Focusing #. m) {-# INLINE zoom #-} instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where zoom l (ReaderT m) = ReaderT (zoom l . m) {-# INLINE zoom #-} instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where zoom l (IdentityT m) = IdentityT (zoom l m) {-# INLINE zoom #-} instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) s t where zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r) {-# INLINE zoom #-} instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) s t where zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r) {-# INLINE zoom #-} instance (Monoid w, Zoom m n s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) s t where zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Strict.runWriterT {-# INLINE zoom #-} instance (Monoid w, Zoom m n s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) s t where zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Lazy.runWriterT {-# INLINE zoom #-} instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT {-# INLINE zoom #-} instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #. l (FocusingMay #. afb)) . liftM May . runMaybeT {-# INLINE zoom #-} instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runErrorT {-# INLINE zoom #-} -- TODO: instance Zoom m m a a => Zoom (ContT r m) (ContT r m) a a where -- | This class allows us to use 'magnify' part of the environment, changing the environment supplied by -- many different 'Monad' transformers. Unlike 'zoom' this can change the environment of a deeply nested 'Monad' transformer. -- -- Also, unlike 'zoom', this can be used with any valid 'Getter', but cannot be used with a 'Traversal' or 'Fold'. class (Magnified m ~ Magnified n, MonadReader b m, MonadReader a n) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where -- | Run a monadic action in a larger environment than it was defined in, using a 'Getter'. -- -- This acts like 'Control.Monad.Reader.Class.local', but can in many cases change the type of the environment as well. -- -- This is commonly used to lift actions in a simpler 'Reader' 'Monad' into a 'Monad' with a larger environment type. -- -- This can be used to edit pretty much any 'Monad' transformer stack with an environment in it: -- -- >>> (1,2) & magnify _2 (+1) -- 3 -- -- >>> flip Reader.runReader (1,2) $ magnify _1 Reader.ask -- 1 -- -- >>> flip Reader.runReader (1,2,[10..20]) $ magnify (_3._tail) Reader.ask -- [11,12,13,14,15,16,17,18,19,20] -- -- @ -- 'magnify' :: 'Getter' s a -> (a -> r) -> s -> r -- 'magnify' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r -- @ -- -- @ -- 'magnify' :: 'Monoid' w => 'Getter' s t -> 'RWS' t w st c -> 'RWS' s w st c -- 'magnify' :: ('Monoid' w, 'Monoid' c) => 'Fold' s a -> 'RWS' a w st c -> 'RWS' s w st c -- ... -- @ magnify :: LensLike' (Magnified m c) a b -> m c -> n c instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where magnify l (ReaderT m) = ReaderT $ getEffect #. l (Effect #. m) {-# INLINE magnify #-} -- | @ -- 'magnify' = 'views' -- @ instance Magnify ((->) b) ((->) a) b a where magnify = views {-# INLINE magnify #-} instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) b a where magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS #. l (EffectRWS #. m) {-# INLINE magnify #-} instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m) {-# INLINE magnify #-} instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where magnify l (IdentityT m) = IdentityT (magnify l m) {-# INLINE magnify #-} lens-3.10/src/Control/Lens/Internal/0000755000000000000000000000000012226700613015447 5ustar0000000000000000lens-3.10/src/Control/Lens/Internal/Action.hs0000644000000000000000000000637612226700613017234 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Action -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Action ( -- ** Actions Effective(..) , Effect(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Lens.Internal.Getter import Control.Monad import Data.Functor.Bind import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor.Unsafe import Data.Semigroup ------------------------------------------------------------------------------- -- Programming with Effects ------------------------------------------------------------------------------- -- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a 'Monad' wrapped around a value. -- -- That said, the 'Monad' is possibly rather unrelated to any 'Applicative' structure. class (Monad m, Functor f, Contravariant f) => Effective m r f | f -> m r where effective :: m r -> f a ineffective :: f a -> m r instance Effective m r f => Effective m (Dual r) (Backwards f) where effective = Backwards . effective . liftM getDual {-# INLINE effective #-} ineffective = liftM Dual . ineffective . forwards {-# INLINE ineffective #-} instance Effective Identity r (Accessor r) where effective = Accessor #. runIdentity {-# INLINE effective #-} ineffective = Identity #. runAccessor {-# INLINE ineffective #-} ------------------------------------------------------------------------------ -- Effect ------------------------------------------------------------------------------ -- | Wrap a monadic effect with a phantom type argument. newtype Effect m r a = Effect { getEffect :: m r } instance Functor (Effect m r) where fmap _ (Effect m) = Effect m {-# INLINE fmap #-} instance Contravariant (Effect m r) where contramap _ (Effect m) = Effect m {-# INLINE contramap #-} instance Monad m => Effective m r (Effect m r) where effective = Effect {-# INLINE effective #-} ineffective = getEffect {-# INLINE ineffective #-} instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where Effect ma <> Effect mb = Effect (liftF2 (<>) ma mb) {-# INLINE (<>) #-} instance (Monad m, Monoid r) => Monoid (Effect m r a) where mempty = Effect (return mempty) {-# INLINE mempty #-} Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) {-# INLINE mappend #-} instance (Apply m, Semigroup r) => Apply (Effect m r) where Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb) {-# INLINE (<.>) #-} instance (Monad m, Monoid r) => Applicative (Effect m r) where pure _ = Effect (return mempty) {-# INLINE pure #-} Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) {-# INLINE (<*>) #-} lens-3.10/src/Control/Lens/Internal/Bazaar.hs0000644000000000000000000001402212226700613017202 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Bazaar -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Bazaar ( Bizarre(..) , Bazaar(..), Bazaar' , BazaarT(..), BazaarT' ) where import Control.Applicative import Control.Arrow as Arrow import Control.Category import Control.Comonad import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- Bizarre ------------------------------------------------------------------------------ -- | This class is used to run the various 'Bazaar' variants used in this -- library. class Profunctor p => Bizarre p w | w -> p where bazaar :: Applicative f => p a (f b) -> w a b t -> f t ------------------------------------------------------------------------------ -- Bazaar ------------------------------------------------------------------------------ -- | 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'. -- -- -- -- A 'Bazaar' 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 @'Bazaar' a b t@ holds @N@ @a@s and a function from @N@ -- @b@s to @t@, (where @N@ might be infinite). -- -- Mnemonically, a 'Bazaar' holds many stores and you can easily add more. -- -- This is a final encoding of 'Bazaar'. newtype Bazaar p a b t = Bazaar { runBazaar :: forall f. Applicative f => p a (f b) -> f t } -- | This alias is helpful when it comes to reducing repetition in type signatures. -- -- @ -- type 'Bazaar'' p a t = 'Bazaar' p a a t -- @ type Bazaar' p a = Bazaar p a a instance IndexedFunctor (Bazaar p) where ifmap f (Bazaar k) = Bazaar (fmap f . k) {-# INLINE ifmap #-} instance Conjoined p => IndexedComonad (Bazaar p) where iextract (Bazaar m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} iduplicate (Bazaar m) = getCompose $ m (Compose #. distrib sell . sell) {-# INLINE iduplicate #-} instance Corepresentable p => Sellable p (Bazaar p) where sell = cotabulate $ \ w -> Bazaar $ tabulate $ \k -> pure (corep k w) {-# INLINE sell #-} instance Profunctor p => Bizarre p (Bazaar p) where bazaar g (Bazaar f) = f g {-# INLINE bazaar #-} instance Functor (Bazaar p a b) where fmap = ifmap {-# INLINE fmap #-} instance Apply (Bazaar p a b) where Bazaar mf <.> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb {-# INLINE (<.>) #-} instance Applicative (Bazaar p a b) where pure a = Bazaar $ \_ -> pure a {-# INLINE pure #-} Bazaar mf <*> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb {-# INLINE (<*>) #-} instance (a ~ b, Conjoined p) => Comonad (Bazaar p a b) where extract = iextract {-# INLINE extract #-} duplicate = iduplicate {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (Bazaar p a b) where (<@>) = (<*>) {-# INLINE (<@>) #-} ------------------------------------------------------------------------------ -- BazaarT ------------------------------------------------------------------------------ -- | 'BazaarT' is like 'Bazaar', 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 BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } -- | This alias is helpful when it comes to reducing repetition in type signatures. -- -- @ -- type 'BazaarT'' p g a t = 'BazaarT' p g a a t -- @ type BazaarT' p g a = BazaarT p g a a instance IndexedFunctor (BazaarT p g) where ifmap f (BazaarT k) = BazaarT (fmap f . k) {-# INLINE ifmap #-} instance Conjoined p => IndexedComonad (BazaarT p g) where iextract (BazaarT m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} iduplicate (BazaarT m) = getCompose $ m (Compose #. distrib sell . sell) {-# INLINE iduplicate #-} instance Corepresentable p => Sellable p (BazaarT p g) where sell = cotabulate $ \ w -> BazaarT (`corep` w) {-# INLINE sell #-} instance Profunctor p => Bizarre p (BazaarT p g) where bazaar g (BazaarT f) = f g {-# INLINE bazaar #-} instance Functor (BazaarT p g a b) where fmap = ifmap {-# INLINE fmap #-} instance Apply (BazaarT p g a b) where BazaarT mf <.> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb {-# INLINE (<.>) #-} instance Applicative (BazaarT p g a b) where pure a = BazaarT $ tabulate $ \_ -> pure (pure a) {-# INLINE pure #-} BazaarT mf <*> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb {-# INLINE (<*>) #-} instance (a ~ b, Conjoined p) => Comonad (BazaarT p g a b) where extract = iextract {-# INLINE extract #-} duplicate = iduplicate {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (BazaarT p g a b) where (<@>) = (<*>) {-# INLINE (<@>) #-} instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where contramap _ = (<$) (error "contramap: BazaarT") {-# INLINE contramap #-} lens-3.10/src/Control/Lens/Internal/ByteString.hs0000644000000000000000000002172312226700613020102 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module spends a lot of time fiddling around with 'Data.ByteString' internals -- to work around on older -- Haskell Platforms and to improve constant and asymptotic factors in our performance. ---------------------------------------------------------------------------- module Control.Lens.Internal.ByteString ( unpackStrict, traversedStrict, traversedStrictTree , unpackStrict8, traversedStrict8, traversedStrictTree8 , unpackLazy, traversedLazy , unpackLazy8, traversedLazy8 ) where import Control.Applicative import Control.Lens import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Internal as BLI import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Internal as BI import Data.Bits import Data.Char import Data.Int (Int64) import Data.Word (Word8) import Foreign.Ptr import Foreign.Storable #if MIN_VERSION_base(4,4,0) import Foreign.ForeignPtr.Safe import Foreign.ForeignPtr.Unsafe #else import Foreign.ForeignPtr #endif import GHC.Base (unsafeChr) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) import GHC.IO (unsafeDupablePerformIO) -- | Traverse a strict 'B.ByteString' from left to right in a biased fashion. traversedStrict :: Int -> IndexedTraversal' Int B.ByteString Word8 traversedStrict i0 pafb (BI.PS fp off len) = let p = unsafeForeignPtrToPtr fp in fmap (rebuild len) (go i0 (p `plusPtr` off) (p `plusPtr` (off+len))) where rebuild n = \xs -> unsafeCreate n $ \p -> go2 p xs go2 !p (x:xs) = poke p x >> go2 (p `plusPtr` 1) xs go2 _ [] = return () -- TODO: use a balanced tree (up to some grain size) go !i !p !q | p == q = pure [] | otherwise = let !x = BI.inlinePerformIO $ do x' <- peek p touchForeignPtr fp return x' in (:) <$> indexed pafb (i :: Int) x <*> go (i + 1) (p `plusPtr` 1) q {-# INLINE traversedStrict #-} -- | Traverse a strict 'B.ByteString' from left to right in a biased fashion -- pretending the bytes are characters. traversedStrict8 :: Int -> IndexedTraversal' Int B.ByteString Char traversedStrict8 i0 pafb (BI.PS fp off len) = let p = unsafeForeignPtrToPtr fp in fmap (rebuild len) (go i0 (p `plusPtr` off) (p `plusPtr` (off+len))) where rebuild n = \xs -> unsafeCreate n $ \p -> go2 p xs go2 !p (x:xs) = poke p (c2w x) >> go2 (p `plusPtr` 1) xs go2 _ [] = return () -- TODO: use a balanced tree (up to some grain size) go !i !p !q | p == q = pure [] | otherwise = let !x = BI.inlinePerformIO $ do x' <- peek p touchForeignPtr fp return x' in (:) <$> indexed pafb (i :: Int) (w2c x) <*> go (i + 1) (p `plusPtr` 1) q {-# INLINE traversedStrict8 #-} grain :: Int grain = 32 {-# INLINE grain #-} -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of -- elements at the leaves. traversedStrictTree :: Int -> IndexedTraversal' Int B.ByteString Word8 traversedStrictTree i0 pafb (BI.PS fp off len) = rebuild len <$> go (unsafeForeignPtrToPtr fp `plusPtr` (off - i0)) i0 (i0 + len) where rebuild n f = unsafeCreate n $ \q -> f $! (q `plusPtr` (off - i0)) go !p !i !j | i + grain < j, k <- i + shiftR (j - i) 1 = (\l r q -> l q >> r q) <$> go p i k <*> go p k j | otherwise = run p i j run !p !i !j | i == j = pure (\_ -> return ()) | otherwise = let !x = BI.inlinePerformIO $ do x' <- peekByteOff p i touchForeignPtr fp return x' in (\y ys !q -> pokeByteOff q i y >> ys q) <$> indexed pafb (i :: Int) x <*> run p (i + 1) j {-# INLINE traversedStrictTree #-} -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of -- elements at the leaves, pretending the bytes are chars. traversedStrictTree8 :: Int -> IndexedTraversal' Int B.ByteString Char traversedStrictTree8 i0 pafb (BI.PS fp off len) = rebuild len <$> go i0 (i0 + len) where p = unsafeForeignPtrToPtr fp `plusPtr` (off - i0) rebuild n f = unsafeCreate n $ \q -> f (q `plusPtr` (off - i0)) go !i !j | i + grain < j, k <- i + shiftR (j - i) 1 = (\l r q -> l q >> r q) <$> go i k <*> go k j | otherwise = run i j run !i !j | i == j = pure (\_ -> return ()) | otherwise = let !x = BI.inlinePerformIO $ do x' <- peekByteOff p i touchForeignPtr fp return x' in (\y ys q -> poke (q `plusPtr` i) (c2w y) >> ys q) <$> indexed pafb (i :: Int) (w2c x) <*> run (i + 1) j {-# INLINE traversedStrictTree8 #-} -- | Unpack a lazy 'Bytestring' unpackLazy :: BL.ByteString -> [Word8] unpackLazy = BL.unpack {-# INLINE unpackLazy #-} -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' traversedLazy :: IndexedTraversal' Int64 BL.ByteString Word8 traversedLazy pafb = go 0 where go _ BLI.Empty = pure BLI.Empty go i (BLI.Chunk b bs) = BLI.Chunk <$> reindexed (fromIntegral :: Int -> Int64) (traversedStrictTree (fromIntegral i)) pafb b <*> go i' bs where !i' = i + B.length b {-# INLINE traversedLazy #-} -- | Unpack a lazy 'BL.ByteString' pretending the bytes are chars. unpackLazy8 :: BL.ByteString -> String unpackLazy8 = BL8.unpack {-# INLINE unpackLazy8 #-} -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' pretending the bytes are chars. traversedLazy8 :: IndexedTraversal' Int64 BL.ByteString Char traversedLazy8 pafb = go 0 where go _ BLI.Empty = pure BLI.Empty go i (BLI.Chunk b bs) = BLI.Chunk <$> reindexed (fromIntegral :: Int -> Int64) (traversedStrictTree8 (fromIntegral i)) pafb b <*> go i' bs where !i' = i + B.length b {-# INLINE traversedLazy8 #-} ------------------------------------------------------------------------------ -- ByteString guts ------------------------------------------------------------------------------ -- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. w2c :: Word8 -> Char w2c = unsafeChr . fromIntegral {-# INLINE w2c #-} -- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and -- silently truncates to 8 bits Chars > '\255'. It is provided as -- convenience for ByteString construction. c2w :: Char -> Word8 c2w = fromIntegral . ord {-# INLINE c2w #-} -- TODO: Should this create the list in chunks, like unpackBytes does in 0.10? -- | Unpack a strict 'B.Bytestring' unpackStrict :: B.ByteString -> [Word8] unpackStrict (BI.PS fp off len) = let p = unsafeForeignPtrToPtr fp in go (p `plusPtr` off) (p `plusPtr` (off+len)) where go !p !q | p == q = [] | otherwise = let !x = BI.inlinePerformIO $ do x' <- peek p touchForeignPtr fp return x' in x : go (p `plusPtr` 1) q {-# INLINE unpackStrict #-} -- TODO: Should this create the list in chunks, like unpackBytes does in 0.10? -- | Unpack a strict 'B.Bytestring', pretending the bytes are chars. unpackStrict8 :: B.ByteString -> String unpackStrict8 (BI.PS fp off len) = let p = unsafeForeignPtrToPtr fp in go (p `plusPtr` off) (p `plusPtr` (off+len)) where go !p !q | p == q = [] | otherwise = let !x = BI.inlinePerformIO $ do x' <- peek p touchForeignPtr fp return x' in w2c x : go (p `plusPtr` 1) q {-# INLINE unpackStrict8 #-} -- | A way of creating ByteStrings outside the IO monad. The @Int@ -- argument gives the final size of the ByteString. Unlike -- 'createAndTrim' the ByteString is not reallocated if the final size -- is less than the estimated size. unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> B.ByteString unsafeCreate l f = unsafeDupablePerformIO (create l f) {-# INLINE unsafeCreate #-} -- | Create ByteString of size @l@ and use action @f@ to fill it's contents. create :: Int -> (Ptr Word8 -> IO ()) -> IO B.ByteString create l f = do fp <- mallocPlainForeignPtrBytes l withForeignPtr fp $ \p -> f p return $! BI.PS fp 0 l {-# INLINE create #-} lens-3.10/src/Control/Lens/Internal/Context.hs0000644000000000000000000002777012226700613017444 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Context -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Context ( IndexedFunctor(..) , IndexedComonad(..) , IndexedComonadStore(..) , Sellable(..) , Context(..), Context' , Pretext(..), Pretext' , PretextT(..), PretextT' ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad import Control.Comonad.Store.Class import Control.Lens.Internal.Indexed import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- IndexedFunctor ------------------------------------------------------------------------------ -- | This is a Bob Atkey -style 2-argument indexed functor. -- -- It exists as a superclass for 'IndexedComonad' and expresses the functoriality -- of an 'IndexedComonad' in its third argument. class IndexedFunctor w where ifmap :: (s -> t) -> w a b s -> w a b t ------------------------------------------------------------------------------ -- IndexedComonad ------------------------------------------------------------------------------ -- | This is a Bob Atkey -style 2-argument indexed comonad. -- -- It exists as a superclass for 'IndexedComonad' and expresses the functoriality -- of an 'IndexedComonad' in its third argument. -- -- The notion of indexed monads is covered in more depth in Bob Atkey's -- "Parameterized Notions of Computation" -- and that construction is dualized here. class IndexedFunctor w => IndexedComonad w where -- | extract from an indexed comonadic value when the indices match. iextract :: w a a t -> t -- | duplicate an indexed comonadic value splitting the index. iduplicate :: w a c t -> w a b (w b c t) iduplicate = iextend id {-# INLINE iduplicate #-} -- | extend a indexed comonadic computation splitting the index. iextend :: (w b c t -> r) -> w a c t -> w a b r iextend f = ifmap f . iduplicate {-# INLINE iextend #-} ------------------------------------------------------------------------------ -- IndexedComonadStore ------------------------------------------------------------------------------ -- | 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. ipos :: w a c t -> a -- | This is the generalization of 'peek' to an indexed comonad store. ipeek :: c -> w a c t -> t ipeek c = iextract . iseek c {-# INLINE ipeek #-} -- | This is the generalization of 'peeks' to an indexed comonad store. ipeeks :: (a -> c) -> w a c t -> t ipeeks f = iextract . iseeks f {-# INLINE ipeeks #-} -- | This is the generalization of 'seek' to an indexed comonad store. iseek :: b -> w a c t -> w b c t -- | This is the generalization of 'seeks' to an indexed comonad store. iseeks :: (a -> b) -> w a c t -> w b c t -- | This is the generalization of 'experiment' to an indexed comonad store. iexperiment :: Functor f => (b -> f c) -> w b c t -> f t iexperiment bfc wbct = (`ipeek` wbct) <$> bfc (ipos wbct) {-# INLINE iexperiment #-} -- | We can always forget the rest of the structure of 'w' and obtain a simpler -- indexed comonad store model called 'Context'. context :: w a b t -> Context a b t context wabt = Context (`ipeek` wabt) (ipos wabt) {-# INLINE context #-} ------------------------------------------------------------------------------ -- Sellable ------------------------------------------------------------------------------ -- | This is used internally to construct a 'Control.Lens.Internal.Bazaar.Bazaar', 'Context' or 'Pretext' -- from a singleton value. class Corepresentable p => Sellable p w | w -> p where sell :: p a (w a b b) ------------------------------------------------------------------------------ -- Context ------------------------------------------------------------------------------ -- | The indexed store can be used to characterize a 'Control.Lens.Lens.Lens' -- and is used by 'Control.Lens.Lens.clone'. -- -- @'Context' a b t@ is isomorphic to -- @newtype 'Context' a b t = 'Context' { runContext :: forall f. 'Functor' f => (a -> f b) -> f t }@, -- and to @exists s. (s, 'Control.Lens.Lens.Lens' s t a b)@. -- -- A 'Context' is like a 'Control.Lens.Lens.Lens' that has already been applied to a some structure. data Context a b t = Context (b -> t) a instance IndexedFunctor Context where ifmap f (Context g t) = Context (f . g) t {-# INLINE ifmap #-} instance IndexedComonad Context where iextract (Context f a) = f a {-# INLINE iextract #-} iduplicate (Context f a) = Context (Context f) a {-# INLINE iduplicate #-} iextend g (Context f a) = Context (g . Context f) a {-# INLINE iextend #-} instance IndexedComonadStore Context where ipos (Context _ a) = a {-# INLINE ipos #-} ipeek b (Context g _) = g b {-# INLINE ipeek #-} ipeeks f (Context g a) = g (f a) {-# INLINE ipeeks #-} iseek a (Context g _) = Context g a {-# INLINE iseek #-} iseeks f (Context g a) = Context g (f a) {-# INLINE iseeks #-} iexperiment f (Context g a) = g <$> f a {-# INLINE iexperiment #-} context = id {-# INLINE context #-} instance Functor (Context a b) where fmap f (Context g t) = Context (f . g) t {-# INLINE fmap #-} instance a ~ b => Comonad (Context a b) where extract (Context f a) = f a {-# INLINE extract #-} duplicate (Context f a) = Context (Context f) a {-# INLINE duplicate #-} extend g (Context f a) = Context (g . Context f) a {-# INLINE extend #-} instance a ~ b => ComonadStore a (Context a b) where pos = ipos {-# INLINE pos #-} peek = ipeek {-# INLINE peek #-} peeks = ipeeks {-# INLINE peeks #-} seek = iseek {-# INLINE seek #-} seeks = iseeks {-# INLINE seeks #-} experiment = iexperiment {-# INLINE experiment #-} instance Sellable (->) Context where sell = Context id {-# INLINE sell #-} -- | @type 'Context'' a s = 'Context' a a s@ type Context' a = Context a a ------------------------------------------------------------------------------ -- Pretext ------------------------------------------------------------------------------ -- | This is a generalized form of 'Context' that can be repeatedly cloned with less -- impact on its performance, and which permits the use of an arbitrary 'Conjoined' -- 'Profunctor' newtype Pretext p a b t = Pretext { runPretext :: forall f. Functor f => p a (f b) -> f t } -- | @type 'Pretext'' p a s = 'Pretext' p a a s@ type Pretext' p a = Pretext p a a instance IndexedFunctor (Pretext p) where ifmap f (Pretext k) = Pretext (fmap f . k) {-# INLINE ifmap #-} instance Functor (Pretext p a b) where fmap = ifmap {-# INLINE fmap #-} instance Conjoined p => IndexedComonad (Pretext p) where iextract (Pretext m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} iduplicate (Pretext m) = getCompose $ m (Compose #. distrib sell . sell) {-# INLINE iduplicate #-} instance (a ~ b, Conjoined p) => Comonad (Pretext p a b) where extract = iextract {-# INLINE extract #-} duplicate = iduplicate {-# INLINE duplicate #-} instance Conjoined p => IndexedComonadStore (Pretext p) where ipos (Pretext m) = getConst $ coarr m $ arr Const {-# INLINE ipos #-} ipeek a (Pretext m) = runIdentity $ coarr m $ arr (\_ -> Identity a) {-# INLINE ipeek #-} ipeeks f (Pretext m) = runIdentity $ coarr m $ arr (Identity . f) {-# INLINE ipeeks #-} iseek a (Pretext m) = Pretext (lmap (lmap (const a)) m) {-# INLINE iseek #-} iseeks f (Pretext m) = Pretext (lmap (lmap f) m) {-# INLINE iseeks #-} iexperiment f (Pretext m) = coarr m (arr f) {-# INLINE iexperiment #-} context (Pretext m) = coarr m (arr sell) {-# INLINE context #-} instance (a ~ b, Conjoined p) => ComonadStore a (Pretext p a b) where pos = ipos {-# INLINE pos #-} peek = ipeek {-# INLINE peek #-} peeks = ipeeks {-# INLINE peeks #-} seek = iseek {-# INLINE seek #-} seeks = iseeks {-# INLINE seeks #-} experiment = iexperiment {-# INLINE experiment #-} instance Corepresentable p => Sellable p (Pretext p) where sell = cotabulate $ \ w -> Pretext (`corep` w) {-# INLINE sell #-} ------------------------------------------------------------------------------ -- PretextT ------------------------------------------------------------------------------ -- | This is a generalized form of 'Context' that can be repeatedly cloned with less -- impact on its performance, and which permits the use of an arbitrary 'Conjoined' -- 'Profunctor'. -- -- The extra phantom 'Functor' is used to let us lie and claim a 'Gettable' instance under -- limited circumstances. This is used internally to permit a number of combinators to -- gracefully degrade when applied to a 'Control.Lens.Fold.Fold', 'Control.Lens.Getter.Getter' -- or 'Control.Lens.Action.Action'. newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } -- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@ type PretextT' p g a = PretextT p g a a instance IndexedFunctor (PretextT p g) where ifmap f (PretextT k) = PretextT (fmap f . k) {-# INLINE ifmap #-} instance Functor (PretextT p g a b) where fmap = ifmap {-# INLINE fmap #-} instance Conjoined p => IndexedComonad (PretextT p g) where iextract (PretextT m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} iduplicate (PretextT m) = getCompose $ m (Compose #. distrib sell . sell) {-# INLINE iduplicate #-} instance (a ~ b, Conjoined p) => Comonad (PretextT p g a b) where extract = iextract {-# INLINE extract #-} duplicate = iduplicate {-# INLINE duplicate #-} instance Conjoined p => IndexedComonadStore (PretextT p g) where ipos (PretextT m) = getConst $ coarr m $ arr Const {-# INLINE ipos #-} ipeek a (PretextT m) = runIdentity $ coarr m $ arr (\_ -> Identity a) {-# INLINE ipeek #-} ipeeks f (PretextT m) = runIdentity $ coarr m $ arr (Identity . f) {-# INLINE ipeeks #-} iseek a (PretextT m) = PretextT (lmap (lmap (const a)) m) {-# INLINE iseek #-} iseeks f (PretextT m) = PretextT (lmap (lmap f) m) {-# INLINE iseeks #-} iexperiment f (PretextT m) = coarr m (arr f) {-# INLINE iexperiment #-} context (PretextT m) = coarr m (arr sell) {-# INLINE context #-} instance (a ~ b, Conjoined p) => ComonadStore a (PretextT p g a b) where pos = ipos {-# INLINE pos #-} peek = ipeek {-# INLINE peek #-} peeks = ipeeks {-# INLINE peeks #-} seek = iseek {-# INLINE seek #-} seeks = iseeks {-# INLINE seeks #-} experiment = iexperiment {-# INLINE experiment #-} instance Corepresentable p => Sellable p (PretextT p g) where sell = cotabulate $ \ w -> PretextT (`corep` w) {-# INLINE sell #-} instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where contramap _ = (<$) (error "contramap: PretextT") {-# INLINE contramap #-} ------------------------------------------------------------------------------ -- Utilities ------------------------------------------------------------------------------ -- | We can convert any 'Conjoined' 'Profunctor' to a function, -- possibly losing information about an index in the process. coarr :: (Representable q, Comonad (Rep q)) => q a b -> a -> b coarr qab = extract . rep qab {-# INLINE coarr #-} lens-3.10/src/Control/Lens/Internal/Deque.hs0000644000000000000000000001340512226700613017051 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Deque -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module is designed to be imported qualified. ----------------------------------------------------------------------------- module Control.Lens.Internal.Deque ( Deque(..) , size , fromList , null , singleton ) 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.Prism import Control.Monad import Data.Foldable as Foldable import Data.Function import Data.Functor.Bind import Data.Functor.Plus import Data.Functor.Reverse import Data.Traversable as Traversable import Data.Semigroup import Data.Profunctor.Unsafe import Prelude hiding (null) -- | A Banker's deque based on Chris Okasaki's \"Purely Functional Data Structures\" data Deque a = BD !Int [a] !Int [a] deriving Show -- | /O(1)/. Determine of a 'Deque' is 'empty'. -- -- >>> null empty -- True -- -- >>> null (singleton 1) -- False null :: Deque a -> Bool null (BD lf _ lr _) = lf + lr == 0 {-# INLINE null #-} -- | /O(1)/. Generate a singleton 'Deque' -- -- >>> singleton 1 -- BD 1 [1] 0 [] singleton :: a -> Deque a singleton a = BD 1 [a] 0 [] {-# INLINE singleton #-} -- | /O(1)/. Calculate the size of a 'Deque' -- -- >>> size (fromList [1,4,6]) -- 3 size :: Deque a -> Int size (BD lf _ lr _) = lf + lr {-# INLINE size #-} -- | /O(n)/ amortized. Construct a 'Deque' from a list of values. -- -- >>> fromList [1,2] -- BD 1 [1] 1 [2] fromList :: [a] -> Deque a fromList = Prelude.foldr cons empty {-# INLINE fromList #-} instance Eq a => Eq (Deque a) where (==) = (==) `on` toList {-# INLINE (==) #-} instance Ord a => Ord (Deque a) where compare = compare `on` toList {-# INLINE compare #-} instance Functor Deque where fmap h (BD lf f lr r) = BD lf (fmap h f) lr (fmap h r) {-# INLINE fmap #-} instance FunctorWithIndex Int Deque where imap h (BD lf f lr r) = BD lf (imap h f) lr (imap (\j -> h (n - j)) r) where !n = lf + lr instance Apply Deque where fs <.> as = fromList (toList fs <.> toList as) {-# INLINE (<.>) #-} instance Applicative Deque where pure a = BD 1 [a] 0 [] {-# INLINE pure #-} fs <*> as = fromList (toList fs <*> toList as) {-# INLINE (<*>) #-} instance Alt Deque where xs ys | size xs < size ys = Foldable.foldr cons ys xs | otherwise = Foldable.foldl snoc xs ys {-# INLINE () #-} instance Plus Deque where zero = BD 0 [] 0 [] {-# INLINE zero #-} instance Alternative Deque where empty = BD 0 [] 0 [] {-# INLINE empty #-} xs <|> ys | size xs < size ys = Foldable.foldr cons ys xs | otherwise = Foldable.foldl snoc xs ys {-# INLINE (<|>) #-} instance Reversing (Deque a) where reversing (BD lf f lr r) = BD lr r lf f {-# INLINE reversing #-} instance Bind Deque where ma >>- k = fromList (toList ma >>= toList . k) {-# INLINE (>>-) #-} instance Monad Deque where return a = BD 1 [a] 0 [] {-# INLINE return #-} ma >>= k = fromList (toList ma >>= toList . k) {-# INLINE (>>=) #-} instance MonadPlus Deque where mzero = empty {-# INLINE mzero #-} mplus = (<|>) {-# INLINE mplus #-} instance Foldable Deque where foldMap h (BD _ f _ r) = foldMap h f `mappend` getDual (foldMap (Dual #. h) r) {-# INLINE foldMap #-} instance FoldableWithIndex Int Deque where ifoldMap h (BD lf f lr r) = ifoldMap h f `mappend` getDual (ifoldMap (\j -> Dual #. h (n - j)) r) where !n = lf + lr {-# INLINE ifoldMap #-} instance Traversable Deque where traverse h (BD lf f lr r) = (BD lf ?? lr) <$> traverse h f <*> backwards traverse h r {-# INLINE traverse #-} instance TraversableWithIndex Int Deque where itraverse h (BD lf f lr r) = (\f' r' -> BD lr f' lr (getReverse r')) <$> itraverse h f <*> itraverse (\j -> h (n - j)) (Reverse r) where !n = lf + lr {-# INLINE itraverse #-} instance Semigroup (Deque a) where xs <> ys | size xs < size ys = Foldable.foldr cons ys xs | otherwise = Foldable.foldl snoc xs ys {-# INLINE (<>) #-} instance Monoid (Deque a) where mempty = BD 0 [] 0 [] {-# INLINE mempty #-} mappend xs ys | size xs < size ys = Foldable.foldr cons ys xs | otherwise = Foldable.foldl snoc xs ys {-# INLINE mappend #-} -- | Check that a 'Deque' satisfies the balance invariants and rebalance if not. check :: Int -> [a] -> Int -> [a] -> Deque a check lf f lr r | lf > 3*lr + 1, i <- div (lf + lr) 2, (f',f'') <- splitAt i f = BD i f' (lf + lr - i) (r ++ reverse f'') | lr > 3*lf + 1, j <- div (lf + lr) 2, (r',r'') <- splitAt j r = BD (lf + lr - j) (f ++ reverse r'') j r' | otherwise = BD lf f lr r {-# INLINE check #-} instance (Choice p, Applicative f) => Cons p f (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 else Right $ case f of [] -> (head r, empty) (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 _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 else Right $ case r of [] -> (empty, head f) (x:xs) -> (check lf f (lr - 1) xs, x) {-# INLINE _Snoc #-} lens-3.10/src/Control/Lens/Internal/Exception.hs0000644000000000000000000002106412226700613017744 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Exception -- Copyright : (C) 2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module uses dirty tricks to generate a 'Handler' from an arbitrary -- 'Fold'. ---------------------------------------------------------------------------- module Control.Lens.Internal.Exception ( Handleable(..) , HandlingException(..) ) where import Control.Exception as Exception import Control.Lens.Fold import Control.Lens.Getter import Control.Monad.CatchIO as CatchIO import Data.IORef import Data.Monoid import Data.Proxy import Data.Reflection import Data.Typeable import System.IO.Unsafe ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------ -- | Both @MonadCatchIO-transformers@ 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. class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Type.Prism' (or any 'Getter', really). -- -- @ -- 'catches' ... [ 'handler' 'Control.Exception.Lens._AssertionFailed' (\s -> 'print' '$' \"Assertion Failed\\n\" '++' s) -- , 'handler' 'Control.Exception.Lens._ErrorCall' (\s -> 'print' '$' \"Error\\n\" '++' s) -- ] -- @ -- -- This works ith both the 'Exception.Handler' type provided by @Control.Exception@: -- -- @ -- 'handler' :: 'Getter' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r -- 'handler' :: 'Fold' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r -- 'handler' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r -- 'handler' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r -- @ -- -- and with the 'CatchIO.Handler' type provided by @Control.Monad.CatchIO@: -- -- @ -- '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 -- @ -- -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@: -- -- @ -- 'handler' :: 'Getter' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler' :: 'Fold' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler' :: 'Control.Lens.Prism.Prism'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- '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 -- | 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. -- -- @ -- 'catches' ... [ 'handler_' 'Control.Exception.Lens._NonTermination' ('return' \"looped\") -- , 'handler_' 'Control.Exception.Lens._StackOverflow' ('return' \"overflow\") -- ] -- @ -- -- This works with the 'Exception.Handler' type provided by @Control.Exception@: -- -- @ -- 'handler_' :: 'Getter' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r -- 'handler_' :: 'Fold' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r -- 'handler_' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r -- 'handler_' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r -- @ -- -- and with the 'CatchIO.Handler' type provided by @Control.Monad.CatchIO@: -- -- @ -- '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 -- @ -- -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@: -- -- @ -- 'handler_' :: 'Getter' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler_' :: 'Fold' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler_' :: 'Control.Lens.Prism.Prism'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- '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_ l = handler l . const {-# INLINE handler_ #-} instance Handleable SomeException IO Exception.Handler where handler = handlerIO instance Handleable SomeException m (CatchIO.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) 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) ------------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------------ -- | There was an 'Exception' caused by abusing the internals of a 'Handler'. data HandlingException = HandlingException deriving (Show,Typeable) 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 -- 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)) [] {-# INLINE typeOf #-} -- 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 toException _ = SomeException HandlingException {-# INLINE toException #-} fromException = fmap Handling . reflect (Proxy :: Proxy s) {-# INLINE fromException #-} lens-3.10/src/Control/Lens/Internal/Fold.hs0000644000000000000000000001473112226700613016675 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Fold -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Fold ( -- * Monoids for folding Folding(..) , Traversed(..) , Sequenced(..) , Max(..), getMax , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost ) where import Control.Applicative import Control.Lens.Internal.Getter import Data.Functor.Bind import Data.Functor.Contravariant import Data.Maybe import Data.Semigroup hiding (Min, getMin, Max, getMax) ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------ -- | A 'Monoid' for a 'Contravariant' 'Applicative'. newtype Folding f a = Folding { getFolding :: f a } instance (Contravariant f, Apply f) => Semigroup (Folding f a) where Folding fr <> Folding fs = Folding (fr .> fs) {-# INLINE (<>) #-} instance (Contravariant f, Applicative f) => Monoid (Folding f a) where mempty = Folding noEffect {-# INLINE mempty #-} Folding fr `mappend` Folding fs = Folding (fr *> fs) {-# INLINE mappend #-} ------------------------------------------------------------------------------ -- Traversed ------------------------------------------------------------------------------ -- | Used internally by 'Control.Lens.Traversal.traverseOf_' and the like. -- -- The argument 'a' of the result should not be used! newtype Traversed a f = Traversed { getTraversed :: f a } instance Apply f => Semigroup (Traversed a f) where Traversed ma <> Traversed mb = Traversed (ma .> mb) {-# INLINE (<>) #-} instance Applicative f => Monoid (Traversed a f) where mempty = Traversed (pure (error "Traversed: value used")) {-# INLINE mempty #-} Traversed ma `mappend` Traversed mb = Traversed (ma *> mb) {-# INLINE mappend #-} ------------------------------------------------------------------------------ -- Sequenced ------------------------------------------------------------------------------ -- | Used internally by 'Control.Lens.Traversal.mapM_' and the like. -- -- The argument 'a' of the result should not be used! newtype Sequenced a m = Sequenced { getSequenced :: m a } instance Apply m => Semigroup (Sequenced a m) where Sequenced ma <> Sequenced mb = Sequenced (ma .> mb) {-# INLINE (<>) #-} instance Monad m => Monoid (Sequenced a m) where mempty = Sequenced (return (error "Sequenced: value used")) {-# INLINE mempty #-} Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) {-# INLINE mappend #-} ------------------------------------------------------------------------------ -- Min ------------------------------------------------------------------------------ -- | Used for 'Control.Lens.Fold.minimumOf'. data Min a = NoMin | Min a instance Ord a => Semigroup (Min a) where NoMin <> m = m m <> NoMin = m Min a <> Min b = Min (min a b) {-# INLINE (<>) #-} instance Ord a => Monoid (Min a) where mempty = NoMin {-# INLINE mempty #-} mappend NoMin m = m mappend m NoMin = m mappend (Min a) (Min b) = Min (min a b) {-# INLINE mappend #-} -- | Obtain the minimum. getMin :: Min a -> Maybe a getMin NoMin = Nothing getMin (Min a) = Just a {-# INLINE getMin #-} ------------------------------------------------------------------------------ -- Max ------------------------------------------------------------------------------ -- | Used for 'Control.Lens.Fold.maximumOf'. data Max a = NoMax | Max a instance Ord a => Semigroup (Max a) where NoMax <> m = m m <> NoMax = m Max a <> Max b = Max (max a b) {-# INLINE (<>) #-} instance Ord a => Monoid (Max a) where mempty = NoMax {-# INLINE mempty #-} mappend NoMax m = m mappend m NoMax = m mappend (Max a) (Max b) = Max (max a b) {-# INLINE mappend #-} -- | Obtain the maximum. getMax :: Max a -> Maybe a getMax NoMax = Nothing getMax (Max a) = Just a {-# INLINE getMax #-} ------------------------------------------------------------------------------ -- Leftmost and Rightmost ------------------------------------------------------------------------------ -- | Used for 'Control.Lens.Fold.preview'. data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) instance Semigroup (Leftmost a) where (<>) = mappend {-# INLINE (<>) #-} instance Monoid (Leftmost a) where mempty = LPure {-# INLINE mempty #-} mappend x y = LStep $ case x of LPure -> y LLeaf _ -> x LStep x' -> case y of -- The last two cases make firstOf produce a Just as soon as any element -- is encountered, and possibly serve as a micro-optimisation; this -- behaviour can be disabled by replacing them with _ -> mappend x y'. -- Note that this means that firstOf (backwards folded) [1..] is Just _|_. LPure -> x' LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x') LStep y' -> mappend x' y' -- | Extract the 'Leftmost' element. This will fairly eagerly determine that it can return 'Just' -- the moment it sees any element at all. getLeftmost :: Leftmost a -> Maybe a getLeftmost LPure = Nothing getLeftmost (LLeaf a) = Just a getLeftmost (LStep x) = getLeftmost x -- | Used for 'Control.Lens.Fold.lastOf'. data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) instance Semigroup (Rightmost a) where (<>) = mappend {-# INLINE (<>) #-} instance Monoid (Rightmost a) where mempty = RPure {-# INLINE mempty #-} mappend x y = RStep $ case y of RPure -> x RLeaf _ -> y RStep y' -> case x of -- The last two cases make lastOf produce a Just as soon as any element -- is encountered, and possibly serve as a micro-optimisation; this -- behaviour can be disabled by replacing them with _ -> mappend x y'. -- Note that this means that lastOf folded [1..] is Just _|_. RPure -> y' RLeaf a -> RLeaf $ fromMaybe a (getRightmost y') RStep x' -> mappend x' y' -- | Extract the 'Rightmost' element. This will fairly eagerly determine that it can return 'Just' -- the moment it sees any element at all. getRightmost :: Rightmost a -> Maybe a getRightmost RPure = Nothing getRightmost (RLeaf a) = Just a getRightmost (RStep x) = getRightmost x lens-3.10/src/Control/Lens/Internal/Getter.hs0000644000000000000000000000545412226700613017245 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Getter -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Getter ( -- * Internal Classes Gettable -- ** Getters , coerce , noEffect , Accessor(..) ) where import Control.Applicative import Data.Functor.Apply import Data.Functor.Contravariant import Data.Semigroup import Data.Void -- | This class is provided mostly for backwards compatibility with lens 3.8, -- but it can also shorten type signatures. class (Contravariant f, Functor f) => Gettable f instance (Contravariant f, Functor f) => Gettable f ------------------------------------------------------------------------------- -- Gettables & Accessors ------------------------------------------------------------------------------- -- | This Generalizes 'Const' so we can apply simple 'Applicative' -- transformations to it and so we can get nicer error messages. -- -- A 'Functor' you can 'coerce' ignores its argument, which it carries solely as a -- phantom type parameter. -- -- By the 'Functor' and 'Contravariant' laws, an instance of 'Gettable' will necessarily satisfy: -- -- @'id' = 'fmap' f = 'coerce' = 'contramap' g@ coerce :: (Contravariant f, Functor f) => f a -> f b coerce a = absurd <$> contramap absurd a {-# INLINE coerce #-} -- | The 'mempty' equivalent for a 'Gettable' 'Applicative' 'Functor'. noEffect :: (Contravariant f, Applicative f) => f a noEffect = coerce $ pure () {-# INLINE noEffect #-} ------------------------------------------------------------------------------- -- Accessors ------------------------------------------------------------------------------- -- | 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 } instance Functor (Accessor r) where fmap _ (Accessor m) = Accessor m {-# INLINE fmap #-} instance Contravariant (Accessor r) where contramap _ (Accessor m) = Accessor m {-# INLINE contramap #-} instance Semigroup r => Apply (Accessor r) where Accessor a <.> Accessor b = Accessor (a <> b) {-# INLINE (<.>) #-} instance Monoid r => Applicative (Accessor r) where pure _ = Accessor mempty {-# INLINE pure #-} Accessor a <*> Accessor b = Accessor (mappend a b) {-# INLINE (<*>) #-} lens-3.10/src/Control/Lens/Internal/Indexed.hs0000644000000000000000000002710512226700613017370 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Indexed -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- Internal implementation details for 'Indexed' lens-likes ---------------------------------------------------------------------------- module Control.Lens.Internal.Indexed ( -- * An Indexed Profunctor Indexed(..) -- * Classes , Conjoined(..) , Indexable(..) -- * Indexing , Indexing(..) , indexing -- * 64-bit Indexing , Indexing64(..) , indexing64 ) where import Control.Applicative import Control.Arrow as Arrow import Control.Category import Control.Comonad import Control.Lens.Internal.Instances () import Control.Monad import Control.Monad.Fix import Data.Distributive import Data.Functor.Bind import Data.Functor.Contravariant import Data.Int import Data.Profunctor import Data.Profunctor.Rep import Data.Traversable import Prelude hiding ((.),id) #ifndef SAFE import Data.Profunctor.Unsafe import Unsafe.Coerce #endif ------------------------------------------------------------------------------ -- Conjoined ------------------------------------------------------------------------------ -- | This is a 'Profunctor' that is both 'Corepresentable' by @f@ and 'Representable' by @g@ such -- that @f@ is left adjoint to @g@. From this you can derive a lot of structure due -- to the preservation of limits and colimits. class ( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p) , Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Distributive (Rep p) , ArrowLoop p, ArrowApply p, ArrowChoice p ) => Conjoined p where -- | 'Conjoined' is strong enough to let us distribute every 'Conjoined' -- 'Profunctor' over every Haskell 'Functor'. This is effectively a -- generalization of 'fmap'. distrib :: Functor f => p a b -> p (f a) (f b) distrib = tabulate . collect . rep {-# INLINE distrib #-} -- | This permits us to make a decision at an outermost point about whether or not we use an index. -- -- Ideally any use of this function should be done in such a way so that you compute the same answer, -- but this cannot be enforced at the type level. conjoined :: ((p ~ (->)) => q (a -> b) r) -> q (p a b) r -> q (p a b) r conjoined _ r = r {-# INLINE conjoined #-} instance Conjoined (->) where distrib = fmap {-# INLINE distrib #-} conjoined l _ = l {-# INLINE conjoined #-} ---------------------------------------------------------------------------- -- Indexable ---------------------------------------------------------------------------- -- | This class permits overloading of function application for things that -- also admit a notion of a key or index. class Conjoined p => Indexable i p where -- | Build a function from an 'indexed' function. indexed :: p a b -> i -> a -> b instance Indexable i (->) where indexed = const {-# INLINE indexed #-} ----------------------------------------------------------------------------- -- Indexed Internals ----------------------------------------------------------------------------- -- | A function with access to a index. This constructor may be useful when you need to store -- an 'Indexable' in a container to avoid @ImpredicativeTypes@. -- -- @index :: Indexed i a b -> i -> a -> b@ newtype Indexed i a b = Indexed { runIndexed :: i -> a -> b } instance Functor (Indexed i a) where fmap g (Indexed f) = Indexed $ \i a -> g (f i a) {-# INLINE fmap #-} instance Apply (Indexed i a) where Indexed f <.> Indexed g = Indexed $ \i a -> f i a (g i a) {-# INLINE (<.>) #-} instance Applicative (Indexed i a) where pure b = Indexed $ \_ _ -> b {-# INLINE pure #-} Indexed f <*> Indexed g = Indexed $ \i a -> f i a (g i a) {-# INLINE (<*>) #-} instance Bind (Indexed i a) where Indexed f >>- k = Indexed $ \i a -> runIndexed (k (f i a)) i a {-# INLINE (>>-) #-} instance Monad (Indexed i a) where return b = Indexed $ \_ _ -> b {-# INLINE return #-} Indexed f >>= k = Indexed $ \i a -> runIndexed (k (f i a)) i a {-# INLINE (>>=) #-} instance MonadFix (Indexed i a) where mfix f = Indexed $ \ i a -> let o = runIndexed (f o) i a in o {-# INLINE mfix #-} instance Profunctor (Indexed i) where dimap ab cd ibc = Indexed $ \i -> cd . runIndexed ibc i . ab {-# INLINE dimap #-} lmap ab ibc = Indexed $ \i -> runIndexed ibc i . ab {-# INLINE lmap #-} rmap bc iab = Indexed $ \i -> bc . runIndexed iab i {-# INLINE rmap #-} #ifndef SAFE ( .# ) ibc _ = unsafeCoerce ibc {-# INLINE ( .# ) #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} #endif instance Corepresentable (Indexed i) where type Corep (Indexed i) = (,) i cotabulate = Indexed . curry {-# INLINE cotabulate #-} corep = uncurry . runIndexed {-# INLINE corep #-} instance Representable (Indexed i) where type Rep (Indexed i) = (->) i tabulate = Indexed . flip {-# INLINE tabulate #-} rep = flip . runIndexed {-# INLINE rep #-} instance Choice (Indexed i) where right' = right {-# INLINE right' #-} instance Strong (Indexed i) where second' = second {-# INLINE second' #-} instance Category (Indexed i) where id = Indexed (const id) {-# INLINE id #-} Indexed f . Indexed g = Indexed $ \i -> f i . g i {-# INLINE (.) #-} instance Arrow (Indexed i) where arr f = Indexed (\_ -> f) {-# INLINE arr #-} first f = Indexed (Arrow.first . runIndexed f) {-# INLINE first #-} second f = Indexed (Arrow.second . runIndexed f) {-# INLINE second #-} Indexed f *** Indexed g = Indexed $ \i -> f i *** g i {-# INLINE (***) #-} Indexed f &&& Indexed g = Indexed $ \i -> f i &&& g i {-# INLINE (&&&) #-} instance ArrowChoice (Indexed i) where left f = Indexed (left . runIndexed f) {-# INLINE left #-} right f = Indexed (right . runIndexed f) {-# INLINE right #-} Indexed f +++ Indexed g = Indexed $ \i -> f i +++ g i {-# INLINE (+++) #-} Indexed f ||| Indexed g = Indexed $ \i -> f i ||| g i {-# INLINE (|||) #-} instance ArrowApply (Indexed i) where app = Indexed $ \ i (f, b) -> runIndexed f i b {-# INLINE app #-} instance ArrowLoop (Indexed i) where loop (Indexed f) = Indexed $ \i b -> let (c,d) = f i (b, d) in c {-# INLINE loop #-} instance Conjoined (Indexed i) where distrib (Indexed iab) = Indexed $ \i fa -> iab i <$> fa {-# INLINE distrib #-} instance i ~ j => Indexable i (Indexed j) where indexed = runIndexed {-# INLINE indexed #-} ------------------------------------------------------------------------------ -- Indexing ------------------------------------------------------------------------------ -- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used -- by 'Control.Lens.Indexed.indexed'. newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) } instance Functor f => Functor (Indexing f) where fmap f (Indexing m) = Indexing $ \i -> case m i of (j, x) -> (j, fmap f x) {-# INLINE fmap #-} instance Apply f => Apply (Indexing f) where Indexing mf <.> Indexing ma = Indexing $ \i -> case mf i of (j, ff) -> case ma j of ~(k, fa) -> (k, ff <.> fa) {-# INLINE (<.>) #-} instance Applicative f => Applicative (Indexing f) where pure x = Indexing $ \i -> (i, pure x) {-# INLINE pure #-} Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of (j, ff) -> case ma j of ~(k, fa) -> (k, ff <*> fa) {-# INLINE (<*>) #-} instance Contravariant f => Contravariant (Indexing f) where contramap f (Indexing m) = Indexing $ \i -> case m i of (j, ff) -> (j, contramap f ff) {-# INLINE contramap #-} -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. -- -- @ -- 'indexing' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int' s t a b -- 'indexing' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int' s t a b -- 'indexing' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int' s t a b -- 'indexing' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int' s t a b -- 'indexing' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.IndexedFold' 'Int' s a -- '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 => ((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 #-} ------------------------------------------------------------------------------ -- Indexing64 ------------------------------------------------------------------------------ -- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int64'@ with a 'Functor', used -- by 'Control.Lens.Indexed.indexed64'. newtype Indexing64 f a = Indexing64 { runIndexing64 :: Int64 -> (Int64, f a) } instance Functor f => Functor (Indexing64 f) where fmap f (Indexing64 m) = Indexing64 $ \i -> case m i of (j, x) -> (j, fmap f x) {-# INLINE fmap #-} instance Apply f => Apply (Indexing64 f) where Indexing64 mf <.> Indexing64 ma = Indexing64 $ \i -> case mf i of (j, ff) -> case ma j of ~(k, fa) -> (k, ff <.> fa) {-# INLINE (<.>) #-} instance Applicative f => Applicative (Indexing64 f) where pure x = Indexing64 $ \i -> (i, pure x) {-# INLINE pure #-} Indexing64 mf <*> Indexing64 ma = Indexing64 $ \i -> case mf i of (j, ff) -> case ma j of ~(k, fa) -> (k, ff <*> fa) {-# INLINE (<*>) #-} instance Contravariant f => Contravariant (Indexing64 f) where contramap f (Indexing64 m) = Indexing64 $ \i -> case m i of (j, ff) -> (j, contramap f ff) {-# INLINE contramap #-} -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. -- -- This combinator is like 'indexing' except that it handles large traversals and folds gracefully. -- -- @ -- 'indexing64' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int64' s t a b -- 'indexing64' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int64' s t a b -- 'indexing64' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int64' s t a b -- 'indexing64' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int64' s t a b -- 'indexing64' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.IndexedFold' 'Int64' s a -- '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 => ((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 #-} lens-3.10/src/Control/Lens/Internal/Instances.hs0000644000000000000000000000303412226700613017732 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Instances -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module includes orphan instances for @(,)@, 'Either' and 'Const' that -- should be supplied by base. ---------------------------------------------------------------------------- module Control.Lens.Internal.Instances () where import Control.Applicative import Data.Foldable import Data.Monoid import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Traversable ------------------------------------------------------------------------------- -- Orphan Instances ------------------------------------------------------------------------------- instance Foldable ((,) b) where foldMap f (_, a) = f a instance Foldable1 ((,) b) where foldMap1 f (_, a) = f a instance Traversable ((,) b) where traverse f (b, a) = (,) b <$> f a instance Traversable1 ((,) b) where traverse1 f (b, a) = (,) b <$> f a instance Foldable (Either a) where foldMap _ (Left _) = mempty foldMap f (Right a) = f a instance Traversable (Either a) where traverse _ (Left b) = pure (Left b) traverse f (Right a) = Right <$> f a instance Foldable (Const m) where foldMap _ _ = mempty instance Traversable (Const m) where traverse _ (Const m) = pure $ Const m lens-3.10/src/Control/Lens/Internal/Iso.hs0000644000000000000000000000556312226700613016546 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Iso -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Iso ( Exchange(..) , Reversing(..) ) where import Data.Profunctor #ifndef SAFE import Data.Profunctor.Unsafe import Unsafe.Coerce #endif import Data.ByteString as StrictB import Data.ByteString.Lazy as LazyB import Data.Text as StrictT import Data.Text.Lazy as LazyT import Data.Vector as Vector import Data.Vector.Primitive as Prim import Data.Vector.Storable as Storable import Data.Vector.Unboxed as Unbox import Data.Sequence as Seq ------------------------------------------------------------------------------ -- Isomorphism: Exchange ------------------------------------------------------------------------------ -- | This is used internally by the 'Control.Lens.Iso.Iso' code to provide -- efficient access to the two functions that make up an isomorphism. data Exchange a b s t = Exchange (s -> a) (b -> t) instance Functor (Exchange a b s) where fmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE fmap #-} instance Profunctor (Exchange a b) where dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) {-# INLINE dimap #-} lmap f (Exchange sa bt) = Exchange (sa . f) bt {-# INLINE lmap #-} rmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE rmap #-} #ifndef SAFE ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} ( .# ) p _ = unsafeCoerce p {-# INLINE ( .# ) #-} #endif ------------------------------------------------------------------------------ -- Reversible ------------------------------------------------------------------------------ -- | This class provides a generalized notion of list reversal extended to other containers. class Reversing t where reversing :: t -> t instance Reversing [a] where reversing = Prelude.reverse instance Reversing StrictB.ByteString where reversing = StrictB.reverse instance Reversing LazyB.ByteString where reversing = LazyB.reverse instance Reversing StrictT.Text where reversing = StrictT.reverse instance Reversing LazyT.Text where reversing = LazyT.reverse instance Reversing (Vector.Vector a) where reversing = Vector.reverse instance Reversing (Seq a) where reversing = Seq.reverse instance Prim a => Reversing (Prim.Vector a) where reversing = Prim.reverse instance Unbox a => Reversing (Unbox.Vector a) where reversing = Unbox.reverse instance Storable a => Reversing (Storable.Vector a) where reversing = Storable.reverse lens-3.10/src/Control/Lens/Internal/Level.hs0000644000000000000000000001357312226700613017063 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Level -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module provides implementation details of the combinators in -- "Control.Lens.Level", which provides for the breadth-first 'Control.Lens.Traversal.Traversal' of -- an arbitrary 'Control.Lens.Traversal.Traversal'. ---------------------------------------------------------------------------- module Control.Lens.Internal.Level ( -- * Levels Level(..) , Deepening(..), deepening , Flows(..) ) where import Control.Applicative import Control.Category import Control.Comonad import Data.Foldable import Data.Functor.Apply import Data.Int import Data.Semigroup import Data.Traversable import Data.Word import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- Levels ------------------------------------------------------------------------------ -- | This data type represents a path-compressed copy of one level of a source -- data structure. We can safely use path-compression because we know the depth -- of the tree. -- -- Path compression is performed by viewing a 'Level' as a PATRICIA trie of the -- paths into the structure to leaves at a given depth, similar in many ways -- to a 'Data.IntMap.IntMap', but unlike a regular PATRICIA trie we do not need -- to store the mask bits merely the depth of the fork. -- -- One invariant of this structure is that underneath a 'Two' node you will not -- find any 'Zero' nodes, so 'Zero' can only occur at the root. data Level i a = Two {-# UNPACK #-} !Word !(Level i a) !(Level i a) | One i a | Zero deriving (Eq,Ord,Show,Read) -- | Append a pair of 'Level' values to get a new 'Level' with path compression. -- -- As the 'Level' type is user-visible, we do not expose this as an illegal -- 'Semigroup' instance, and just use it directly in 'Deepening' as needed. lappend :: Level i a -> Level i a -> Level i a lappend Zero Zero = Zero lappend Zero r@One{} = r lappend l@One{} Zero = l lappend Zero (Two n l r) = Two (n + 1) l r lappend (Two n l r) Zero = Two (n + 1) l r lappend l r = Two 0 l r {-# INLINE lappend #-} instance Functor (Level i) where fmap f = go where go (Two n l r) = Two n (go l) (go r) go (One i a) = One i (f a) go Zero = Zero {-# INLINE fmap #-} instance Foldable (Level i) where foldMap f = go where go (Two _ l r) = go l `mappend` go r go (One _ a) = f a go Zero = mempty {-# INLINE foldMap #-} instance Traversable (Level i) where traverse f = go where go (Two n l r) = Two n <$> go l <*> go r go (One i a) = One i <$> f a go Zero = pure Zero {-# INLINE traverse #-} ------------------------------------------------------------------------------ -- Generating Levels ------------------------------------------------------------------------------ -- | This is an illegal 'Monoid' used to construct a single 'Level'. newtype Deepening i a = Deepening { runDeepening :: forall r. Int -> (Level i a -> Bool -> r) -> r } instance Semigroup (Deepening i a) where Deepening l <> Deepening r = Deepening $ \ n k -> case n of 0 -> k Zero True _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) {-# INLINE (<>) #-} -- | This is an illegal 'Monoid'. instance Monoid (Deepening i a) where mempty = Deepening $ \ _ k -> k Zero False {-# INLINE mempty #-} mappend (Deepening l) (Deepening r) = Deepening $ \ n k -> case n of 0 -> k Zero True _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) {-# INLINE mappend #-} -- | Generate the leaf of a given 'Deepening' based on whether or not we're at the correct depth. deepening :: i -> a -> Deepening i a deepening i a = Deepening $ \n k -> k (if n == 0 then One i a else Zero) False {-# INLINE deepening #-} ------------------------------------------------------------------------------ -- Reassembling Levels ------------------------------------------------------------------------------ -- | This is an illegal 'Applicative' used to replace the contents of a list of consecutive 'Level' values -- representing each layer of a structure into the original shape that they were derived from. -- -- Attempting to 'Flow' something back into a shape other than the one it was taken from will fail. newtype Flows i b a = Flows { runFlows :: [Level i b] -> a } instance Functor (Flows i b) where fmap f (Flows g) = Flows (f . g) {-# INLINE fmap #-} -- | Walk down one constructor in a 'Level', veering left. triml :: Level i b -> Level i b triml (Two 0 l _) = l triml (Two n l r) = Two (n - 1) l r triml x = x {-# INLINE triml #-} -- | Walk down one constructor in a 'Level', veering right. trimr :: Level i b -> Level i b trimr (Two 0 _ r) = r trimr (Two n l r) = Two (n - 1) l r trimr x = x {-# INLINE trimr #-} instance Apply (Flows i b) where Flows mf <.> Flows ma = Flows $ \ xss -> case xss of [] -> mf [] (ma []) (_:xs) -> mf (triml <$> xs) $ ma (trimr <$> xs) {-# INLINE (<.>) #-} -- | This is an illegal 'Applicative'. instance Applicative (Flows i b) where pure a = Flows (const a) {-# INLINE pure #-} Flows mf <*> Flows ma = Flows $ \ xss -> case xss of [] -> mf [] (ma []) (_:xs) -> mf (triml <$> xs) $ ma (trimr <$> xs) {-# INLINE (<*>) #-} lens-3.10/src/Control/Lens/Internal/Magma.hs0000644000000000000000000002160512226700613017031 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Magma ( -- * Magma Magma(..) , runMagma -- * Molten , Molten(..) -- * Mafic , Mafic(..) , runMafic -- * TakingWhile , TakingWhile(..) , runTakingWhile ) where import Control.Applicative import Control.Category import Control.Comonad import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Data.Foldable import Data.Functor.Apply import Data.Functor.Contravariant import Data.Monoid import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Data.Traversable import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- Magma ------------------------------------------------------------------------------ -- | This provides a way to peek at the internal structure of a -- 'Control.Lens.Traversal.Traversal' or 'Control.Lens.Traversal.IndexedTraversal' data Magma i t b a where MagmaAp :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a MagmaPure :: x -> Magma i x b a MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a Magma :: i -> a -> Magma i b b a instance Functor (Magma i t b) where fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y) fmap _ (MagmaPure x) = MagmaPure x fmap f (MagmaFmap xy x) = MagmaFmap xy (fmap f x) fmap f (Magma i a) = Magma i (f a) instance Foldable (Magma i t b) where foldMap f (MagmaAp x y) = foldMap f x `mappend` foldMap f y foldMap _ MagmaPure{} = mempty foldMap f (MagmaFmap _ x) = foldMap f x foldMap f (Magma _ a) = f a instance Traversable (Magma i t b) where traverse f (MagmaAp x y) = MagmaAp <$> traverse f x <*> traverse f y traverse _ (MagmaPure x) = pure (MagmaPure x) traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x traverse f (Magma i a) = Magma i <$> f a instance (Show i, Show a) => Show (Magma i t b a) where showsPrec d (MagmaAp x y) = showParen (d > 4) $ showsPrec 4 x . showString " <*> " . showsPrec 5 y showsPrec d (MagmaPure _) = showParen (d > 10) $ showString "pure .." showsPrec d (MagmaFmap _ x) = showParen (d > 4) $ showString ".. <$> " . showsPrec 5 x showsPrec d (Magma i a) = showParen (d > 10) $ showString "Magma " . showsPrec 11 i . showChar ' ' . showsPrec 11 a -- | Run a 'Magma' where all the individual leaves have been converted to the -- expected type runMagma :: Magma i t a a -> t runMagma (MagmaAp l r) = runMagma l (runMagma r) runMagma (MagmaFmap f r) = f (runMagma r) runMagma (MagmaPure x) = x runMagma (Magma _ a) = a ------------------------------------------------------------------------------ -- Molten ------------------------------------------------------------------------------ -- | This is a a non-reassociating initially encoded version of 'Bazaar'. newtype Molten i a b t = Molten { runMolten :: Magma i t b a } instance Functor (Molten i a b) where fmap f (Molten xs) = Molten (MagmaFmap f xs) {-# INLINE fmap #-} instance Apply (Molten i a b) where (<.>) = (<*>) {-# INLINE (<.>) #-} instance Applicative (Molten i a b) where pure = Molten #. MagmaPure {-# INLINE pure #-} Molten xs <*> Molten ys = Molten (MagmaAp xs ys) {-# INLINE (<*>) #-} instance Sellable (Indexed i) (Molten i) where sell = Indexed (\i -> Molten #. Magma i) {-# INLINE sell #-} instance Bizarre (Indexed i) (Molten i) where bazaar f (Molten (MagmaAp x y)) = bazaar f (Molten x) <*> bazaar f (Molten y) bazaar f (Molten (MagmaFmap g x)) = g <$> bazaar f (Molten x) bazaar _ (Molten (MagmaPure x)) = pure x bazaar f (Molten (Magma i a)) = indexed f i a instance IndexedFunctor (Molten i) where ifmap f (Molten xs) = Molten (MagmaFmap f xs) {-# INLINE ifmap #-} instance IndexedComonad (Molten i) where iextract (Molten (MagmaAp x y)) = iextract (Molten x) (iextract (Molten y)) iextract (Molten (MagmaFmap f y)) = f (iextract (Molten y)) iextract (Molten (MagmaPure x)) = x iextract (Molten (Magma _ a)) = a iduplicate (Molten (Magma i a)) = Molten #. Magma i <$> Molten (Magma i a) iduplicate (Molten (MagmaPure x)) = pure (pure x) iduplicate (Molten (MagmaFmap f y)) = iextend (fmap f) (Molten y) iduplicate (Molten (MagmaAp x y)) = iextend (<*>) (Molten x) <*> iduplicate (Molten y) iextend k (Molten (Magma i a)) = (k .# Molten) . Magma i <$> Molten (Magma i a) iextend k (Molten (MagmaPure x)) = pure (k (pure x)) iextend k (Molten (MagmaFmap f y)) = iextend (k . fmap f) (Molten y) iextend k (Molten (MagmaAp x y)) = iextend (\x' y' -> k $ x' <*> y') (Molten x) <*> iduplicate (Molten y) instance a ~ b => Comonad (Molten i a b) where extract = iextract {-# INLINE extract #-} extend = iextend {-# INLINE extend #-} duplicate = iduplicate {-# INLINE duplicate #-} ------------------------------------------------------------------------------ -- Mafic ------------------------------------------------------------------------------ -- | This is used to generate an indexed magma from an unindexed source -- -- By constructing it this way we avoid infinite reassociations in sums where possible. data Mafic a b t = Mafic Int (Int -> Magma Int t b a) -- | Generate a 'Magma' using from a prefix sum. runMafic :: Mafic a b t -> Magma Int t b a runMafic (Mafic _ k) = k 0 instance Functor (Mafic a b) where fmap f (Mafic w k) = Mafic w (MagmaFmap f . k) {-# INLINE fmap #-} instance Apply (Mafic a b) where Mafic wf mf <.> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) {-# INLINE (<.>) #-} instance Applicative (Mafic a b) where pure a = Mafic 0 $ \_ -> MagmaPure a {-# INLINE pure #-} Mafic wf mf <*> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) {-# INLINE (<*>) #-} instance Sellable (->) Mafic where sell a = Mafic 1 $ \ i -> Magma i a {-# INLINE sell #-} instance Bizarre (Indexed Int) Mafic where bazaar (pafb :: Indexed Int a (f b)) (Mafic _ k) = go (k 0) where go :: Applicative f => Magma Int t b a -> f t go (MagmaAp x y) = go x <*> go y go (MagmaFmap f x) = f <$> go x go (MagmaPure x) = pure x go (Magma i a) = indexed pafb (i :: Int) a {-# INLINE bazaar #-} instance IndexedFunctor Mafic where ifmap f (Mafic w k) = Mafic w (MagmaFmap f . k) {-# INLINE ifmap #-} ------------------------------------------------------------------------------ -- TakingWhile ------------------------------------------------------------------------------ -- | This is used to generate an indexed magma from an unindexed source -- -- By constructing it this way we avoid infinite reassociations where possible. data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. runTakingWhile :: Corepresentable p => TakingWhile p f a b t -> Magma () t b (Corep p a) runTakingWhile (TakingWhile _ _ k) = k True instance Functor (TakingWhile p f a b) where fmap f (TakingWhile w t k) = let ft = f t in TakingWhile w ft $ \b -> if b then MagmaFmap f (k b) else MagmaPure ft {-# INLINE fmap #-} instance Apply (TakingWhile p f a b) where TakingWhile wf tf mf <.> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) {-# INLINE (<.>) #-} instance Applicative (TakingWhile p f a b) where pure a = TakingWhile True a $ \_ -> MagmaPure a {-# INLINE pure #-} TakingWhile wf tf mf <*> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) {-# INLINE (<*>) #-} instance Corepresentable p => Bizarre p (TakingWhile p g) where bazaar (pafb :: p a (f b)) ~(TakingWhile _ _ k) = go (k True) where go :: Applicative f => Magma () t b (Corep p a) -> f t go (MagmaAp x y) = go x <*> go y go (MagmaFmap f x) = f <$> go x go (MagmaPure x) = pure x go (Magma _ wa) = corep pafb wa {-# INLINE bazaar #-} instance Contravariant f => Contravariant (TakingWhile p f a b) where contramap _ = (<$) (error "contramap: TakingWhile") {-# INLINE contramap #-} instance IndexedFunctor (TakingWhile p f) where ifmap = fmap {-# INLINE ifmap #-} lens-3.10/src/Control/Lens/Internal/Prism.hs0000644000000000000000000000412112226700613017073 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Prism -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Prism ( Market(..) , Market' ) where import Data.Profunctor #ifndef SAFE import Data.Profunctor.Unsafe import Unsafe.Coerce #endif ------------------------------------------------------------------------------ -- Prism: Market ------------------------------------------------------------------------------ -- | This type is used internally by the 'Control.Lens.Prism.Prism' code to -- provide efficient access to the two parts of a 'Prism'. data Market a b s t = Market (b -> t) (s -> Either t a) -- | @type 'Market'' a s t = 'Market' a a s t@ type Market' a = Market a a instance Functor (Market a b s) where fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE fmap #-} instance Profunctor (Market a b) where dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) {-# INLINE dimap #-} lmap f (Market bt seta) = Market bt (seta . f) {-# INLINE lmap #-} rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE rmap #-} #ifndef SAFE ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} ( .# ) p _ = unsafeCoerce p {-# INLINE ( .# ) #-} #endif instance Choice (Market a b) where left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of Left s -> case seta s of Left t -> Left (Left t) Right a -> Right a Right c -> Left (Right c) {-# INLINE left' #-} right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of Left c -> Left (Left c) Right s -> case seta s of Left t -> Left (Right t) Right a -> Right a {-# INLINE right' #-} lens-3.10/src/Control/Lens/Internal/Review.hs0000644000000000000000000001062212226700613017245 0ustar0000000000000000{-# 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 -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Review ( -- * Internal Classes Reviewable, -- * Reviews retagged, Reviewed(..) ) 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. class (Profunctor p, Bifunctor p) => Reviewable p instance (Profunctor p, Bifunctor p) => Reviewable p ------------------------------------------------------------------------------ -- Review: Reviewed ------------------------------------------------------------------------------ -- | This is a profunctor used internally to implement "Review" -- -- It plays a role similar to that of 'Control.Lens.Internal.Getter.Accessor' -- 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 #-} lens-3.10/src/Control/Lens/Internal/Setter.hs0000644000000000000000000000771512226700613017263 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Setter -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Setter ( -- ** 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 import Data.Traversable ----------------------------------------------------------------------------- -- Settable ----------------------------------------------------------------------------- -- | Anything 'Settable' must be isomorphic to the 'Identity' 'Functor'. class (Applicative f, Distributive f, Traversable f) => Settable f where untainted :: f a -> a untaintedDot :: Profunctor p => p a (f b) -> p a b untaintedDot g = g `seq` rmap untainted g {-# INLINE untaintedDot #-} taintedDot :: Profunctor p => p a b -> p a (f b) taintedDot g = g `seq` rmap pure g {-# INLINE taintedDot #-} -- | So you can pass our 'Control.Lens.Setter.Setter' into combinators from other lens libraries. instance Settable Identity where untainted = runIdentity {-# INLINE untainted #-} untaintedDot = (runIdentity #.) {-# INLINE untaintedDot #-} taintedDot = (Identity #.) {-# INLINE taintedDot #-} -- | 'Control.Lens.Fold.backwards' instance Settable f => Settable (Backwards f) where untainted = untaintedDot forwards {-# INLINE untainted #-} instance (Settable f, Settable g) => Settable (Compose f g) where 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 #-} lens-3.10/src/Control/Lens/Internal/Zipper.hs0000644000000000000000000010123312226700613017254 0ustar0000000000000000{-# 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 -- 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 {-# ANN module "HLint: ignore Use foldl" #-} ------------------------------------------------------------------------------ -- * 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 lens-3.10/src/Control/Lens/Internal/Zoom.hs0000644000000000000000000002572312226700613016740 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Zoom -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Zoom ( -- * Zoom Zoomed , Focusing(..) , FocusingWith(..) , FocusingPlus(..) , FocusingOn(..) , FocusingMay(..), May(..) , FocusingErr(..), Err(..) -- * Magnify , Magnified , EffectRWS(..) ) where import Control.Applicative 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 import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Error import Control.Monad.Trans.List import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Data.Functor.Bind import Data.Functor.Contravariant import Data.Semigroup import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- Zoomed ------------------------------------------------------------------------------ -- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. type family Zoomed (m :: * -> *) :: * -> * -> * type instance Zoomed (Strict.StateT s z) = Focusing z type instance Zoomed (Lazy.StateT s z) = Focusing z type instance Zoomed (ReaderT e m) = Zoomed m type instance Zoomed (IdentityT m) = Zoomed m type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) ------------------------------------------------------------------------------ -- Focusing ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Lens.Zoom' to 'Control.Lens.Lens.zoom' into 'Control.Monad.State.StateT'. newtype Focusing m s a = Focusing { unfocusing :: m (s, a) } instance Monad m => Functor (Focusing m s) where fmap f (Focusing m) = Focusing $ do (s, a) <- m return (s, f a) {-# INLINE fmap #-} instance (Monad m, Semigroup s) => Apply (Focusing m s) where Focusing mf <.> Focusing ma = Focusing $ do (s, f) <- mf (s', a) <- ma return (s <> s', f a) {-# INLINE (<.>) #-} instance (Monad m, Monoid s) => Applicative (Focusing m s) where pure a = Focusing (return (mempty, a)) {-# INLINE pure #-} Focusing mf <*> Focusing ma = Focusing $ do (s, f) <- mf (s', a) <- ma return (mappend s s', f a) {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ -- FocusingWith ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Lens.Zoom' to 'Control.Lens.Lens.zoom' into 'Control.Monad.RWS.RWST'. newtype FocusingWith w m s a = FocusingWith { unfocusingWith :: m (s, a, w) } instance Monad m => Functor (FocusingWith w m s) where fmap f (FocusingWith m) = FocusingWith $ do (s, a, w) <- m return (s, f a, w) {-# INLINE fmap #-} instance (Monad m, Semigroup s, Semigroup w) => Apply (FocusingWith w m s) where FocusingWith mf <.> FocusingWith ma = FocusingWith $ do (s, f, w) <- mf (s', a, w') <- ma return (s <> s', f a, w <> w') {-# INLINE (<.>) #-} instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where pure a = FocusingWith (return (mempty, a, mempty)) {-# INLINE pure #-} FocusingWith mf <*> FocusingWith ma = FocusingWith $ do (s, f, w) <- mf (s', a, w') <- ma return (mappend s s', f a, mappend w w') {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ -- FocusingPlus ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Lens.Zoom' to 'Control.Lens.Lens.zoom' into 'Control.Monad.Writer.WriterT'. newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a } instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where fmap f (FocusingPlus as) = FocusingPlus (fmap f as) {-# INLINE fmap #-} instance Apply (k (s, w)) => Apply (FocusingPlus w k s) where FocusingPlus kf <.> FocusingPlus ka = FocusingPlus (kf <.> ka) {-# INLINE (<.>) #-} instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where pure = FocusingPlus . pure {-# INLINE pure #-} FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka) {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ -- FocusingOn ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Lens.Zoom' to 'Control.Lens.Lens.zoom' into 'Control.Monad.Trans.Maybe.MaybeT' or 'Control.Monad.Trans.List.ListT'. newtype FocusingOn f k s a = FocusingOn { unfocusingOn :: k (f s) a } instance Functor (k (f s)) => Functor (FocusingOn f k s) where fmap f (FocusingOn as) = FocusingOn (fmap f as) {-# INLINE fmap #-} instance Apply (k (f s)) => Apply (FocusingOn f k s) where FocusingOn kf <.> FocusingOn ka = FocusingOn (kf <.> ka) {-# INLINE (<.>) #-} instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where pure = FocusingOn . pure {-# INLINE pure #-} FocusingOn kf <*> FocusingOn ka = FocusingOn (kf <*> ka) {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ -- May ------------------------------------------------------------------------------ -- | Make a 'Monoid' out of 'Maybe' for error handling. newtype May a = May { getMay :: Maybe a } instance Semigroup a => Semigroup (May a) where May Nothing <> _ = May Nothing _ <> May Nothing = May Nothing May (Just a) <> May (Just b) = May (Just (a <> b)) {-# INLINE (<>) #-} instance Monoid a => Monoid (May a) where mempty = May (Just mempty) {-# INLINE mempty #-} May Nothing `mappend` _ = May Nothing _ `mappend` May Nothing = May Nothing May (Just a) `mappend` May (Just b) = May (Just (mappend a b)) {-# INLINE mappend #-} ------------------------------------------------------------------------------ -- FocusingMay ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Lens.Zoom' to 'Control.Lens.Lens.zoom' into 'Control.Monad.Error.ErrorT'. newtype FocusingMay k s a = FocusingMay { unfocusingMay :: k (May s) a } instance Functor (k (May s)) => Functor (FocusingMay k s) where fmap f (FocusingMay as) = FocusingMay (fmap f as) {-# INLINE fmap #-} instance Apply (k (May s)) => Apply (FocusingMay k s) where FocusingMay kf <.> FocusingMay ka = FocusingMay (kf <.> ka) {-# INLINE (<.>) #-} instance Applicative (k (May s)) => Applicative (FocusingMay k s) where pure = FocusingMay . pure {-# INLINE pure #-} FocusingMay kf <*> FocusingMay ka = FocusingMay (kf <*> ka) {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ -- Err ------------------------------------------------------------------------------ -- | Make a 'Monoid' out of 'Either' for error handling. newtype Err e a = Err { getErr :: Either e a } instance Semigroup a => Semigroup (Err e a) where Err (Left e) <> _ = Err (Left e) _ <> Err (Left e) = Err (Left e) Err (Right a) <> Err (Right b) = Err (Right (a <> b)) {-# INLINE (<>) #-} instance Monoid a => Monoid (Err e a) where mempty = Err (Right mempty) {-# INLINE mempty #-} Err (Left e) `mappend` _ = Err (Left e) _ `mappend` Err (Left e) = Err (Left e) Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b)) {-# INLINE mappend #-} ------------------------------------------------------------------------------ -- FocusingErr ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Lens.Zoom' to 'Control.Lens.Lens.zoom' into 'Control.Monad.Error.ErrorT'. newtype FocusingErr e k s a = FocusingErr { unfocusingErr :: k (Err e s) a } instance Functor (k (Err e s)) => Functor (FocusingErr e k s) where fmap f (FocusingErr as) = FocusingErr (fmap f as) {-# INLINE fmap #-} instance Apply (k (Err e s)) => Apply (FocusingErr e k s) where FocusingErr kf <.> FocusingErr ka = FocusingErr (kf <.> ka) {-# INLINE (<.>) #-} instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where pure = FocusingErr . pure {-# INLINE pure #-} FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka) {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ -- Magnified ------------------------------------------------------------------------------ -- | 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 (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 ------------------------------------------------------------------------------ -- EffectRWS ------------------------------------------------------------------------------ -- | Wrap a monadic effect with a phantom type argument. Used when magnifying 'Control.Monad.RWS.RWST'. newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) } instance Functor (EffectRWS w st m s) where fmap _ (EffectRWS m) = EffectRWS m {-# INLINE fmap #-} instance (Semigroup s, Semigroup w, Bind m) => Apply (EffectRWS w st m s) where EffectRWS m <.> EffectRWS n = EffectRWS $ \st -> m st >>- \ (s,t,w) -> fmap (\(s',u,w') -> (s <> s', u, w <> w')) (n t) {-# INLINE (<.>) #-} instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where pure _ = EffectRWS $ \st -> return (mempty, st, mempty) {-# INLINE pure #-} EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w') {-# INLINE (<*>) #-} instance Contravariant (EffectRWS w st m s) where contramap _ (EffectRWS m) = EffectRWS m {-# INLINE contramap #-} lens-3.10/src/Control/Monad/0000755000000000000000000000000012226700613014030 5ustar0000000000000000lens-3.10/src/Control/Monad/Error/0000755000000000000000000000000012226700613015121 5ustar0000000000000000lens-3.10/src/Control/Monad/Error/Lens.hs0000644000000000000000000002121412226700613016356 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Error.Lens -- Copyright : (C) 2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Control.Monad.Error -- ---------------------------------------------------------------------------- module Control.Monad.Error.Lens ( -- * Catching catching, catching_ -- * Handling , handling, handling_ -- * Trying , trying -- * Handlers , catches , Handler(..) , Handleable(..) -- * Throwing , throwing ) where import Control.Applicative import Control.Lens import Control.Lens.Internal.Exception import Control.Monad.Error import Data.Functor.Plus import Data.Monoid import Data.Semigroup (Semigroup(..)) ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ -- | Catch exceptions that match a given 'Prism' (or any 'Getter', really). -- -- @ -- 'catching' :: 'MonadError' e m => 'Prism'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Lens'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Traversal'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Iso'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Getter' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Fold' e a -> m r -> (a -> m r) -> m r -- @ catching :: MonadError e m => Getting (First a) e a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} -- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding -- the information about the match. This is particuarly useful when you have -- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- @ -- 'catching_' :: 'MonadError' e m => 'Prism'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r -- @ catching_ :: MonadError e m => Getting (First a) e a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} ------------------------------------------------------------------------------ -- Handling ------------------------------------------------------------------------------ -- | A version of 'catching' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. -- -- @ -- 'handling' :: 'MonadError' e m => 'Prism'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Lens'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Traversal'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Iso'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Fold' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Getter' e a -> (a -> m r) -> m r -> m r -- @ handling :: MonadError e m => Getting (First a) e a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} -- | A version of 'catching_' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. -- -- @ -- 'handling_' :: 'MonadError' e m => 'Prism'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r -- @ handling_ :: MonadError e m => Getting (First a) e a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} ------------------------------------------------------------------------------ -- Trying ------------------------------------------------------------------------------ -- | '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. -- -- @ -- 'trying' :: 'MonadError' e m => 'Prism'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Lens'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Iso'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Getter' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Fold' e a -> m r -> m ('Either' a r) -- @ trying :: MonadError e m => Getting (First a) e a -> m r -> m (Either a r) trying l m = catching l (liftM Right m) (return . Left) ------------------------------------------------------------------------------ -- Catches ------------------------------------------------------------------------------ -- | -- This function exists to remedy a gap between the functionality of @Control.Exception@ -- and @Control.Monad.Error@. @Control.Exception@ supplies 'Control.Exception.catches' and -- a notion of 'Control.Exception.Handler', which we duplicate here in a form suitable for -- working with any 'MonadError' instance. -- -- Sometimes you want to catch two different sorts of error. You could -- do something like -- -- @ -- f = 'handling' _Foo handleFoo ('handling' _Bar handleBar expr) -- @ -- -- -- However, there are a couple of problems with this approach. The first is -- that having two exception handlers is inefficient. However, the more -- serious issue is that the second exception handler will catch exceptions -- in the first, e.g. in the example above, if @handleFoo@ uses 'throwError' -- then the second exception handler will catch it. -- -- Instead, we provide a function 'catches', which would be used thus: -- -- @ -- f = 'catches' expr [ 'handler' _Foo handleFoo -- , 'handler' _Bar handleBar -- ] -- @ catches :: MonadError e m => m a -> [Handler e m a] -> m a catches m hs = catchError m go where go e = foldr tryHandler (throwError e) hs where tryHandler (Handler ema amr) res = maybe res amr (ema e) ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------ -- | You need this when using 'catches'. data Handler e m r = forall a. Handler (e -> Maybe a) (a -> m r) instance Monad m => Functor (Handler e m) where fmap f (Handler ema amr) = Handler ema $ \a -> do r <- amr a return (f r) {-# INLINE fmap #-} instance Monad m => Semigroup (Handler e m a) where (<>) = mappend {-# INLINE (<>) #-} instance Monad m => Alt (Handler e m) where Handler ema amr Handler emb bmr = Handler emab abmr where emab e = Left <$> ema e <|> Right <$> emb e abmr = either amr bmr {-# INLINE () #-} instance Monad m => Plus (Handler e m) where zero = Handler (const Nothing) undefined {-# INLINE zero #-} instance Monad m => Monoid (Handler e m a) where mempty = zero {-# INLINE mempty #-} mappend = () {-# INLINE mappend #-} instance Handleable e m (Handler e m) where handler = Handler . preview {-# INLINE handler #-} ------------------------------------------------------------------------------ -- Throwing ------------------------------------------------------------------------------ -- | Throw an 'Exception' described by a 'Prism'. -- -- @'throwing' l ≡ 'reviews' l 'throwError'@ -- -- @ -- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> a -- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> a -- @ throwing :: MonadError e m => AReview e e t t -> t -> m x throwing l = reviews l throwError {-# INLINE throwing #-} ------------------------------------------------------------------------------ -- Misc. ------------------------------------------------------------------------------ -- | Helper function to provide conditional catch behavior. catchJust :: MonadError e m => (e -> Maybe t) -> m a -> (t -> m a) -> m a catchJust f m k = catchError m $ \ e -> case f e of Nothing -> throwError e Just x -> k x {-# INLINE catchJust #-} lens-3.10/src/Control/Parallel/0000755000000000000000000000000012226700613014526 5ustar0000000000000000lens-3.10/src/Control/Parallel/Strategies/0000755000000000000000000000000012226700613016640 5ustar0000000000000000lens-3.10/src/Control/Parallel/Strategies/Lens.hs0000644000000000000000000000534212226700613020101 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_parallel #define MIN_VERSION_parallel(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL > 700) #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Parallel.Strategies.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A 'Lens' or 'Traversal' can be used to take the role of 'Traversable' in -- @Control.Parallel.Strategies@, enabling those combinators to work with -- monomorphic containers. ---------------------------------------------------------------------------- module Control.Parallel.Strategies.Lens ( evalOf , parOf , after , throughout ) where import Control.Lens import Control.Parallel.Strategies -- | Evaluate the targets of a 'Lens' or 'Traversal' into a data structure -- according to the given 'Strategy'. -- -- @ -- 'evalTraversable' = 'evalOf' 'traverse' = 'traverse' -- 'evalOf' = 'id' -- @ -- -- @ -- 'evalOf' :: 'Lens'' s a -> 'Strategy' a -> 'Strategy' s -- 'evalOf' :: 'Traversal'' s a -> 'Strategy' a -> 'Strategy' s -- 'evalOf' :: (a -> 'Eval' a) -> s -> 'Eval' s) -> 'Strategy' a -> 'Strategy' s -- @ evalOf :: LensLike' Eval s a -> Strategy a -> Strategy s evalOf l = l {-# INLINE evalOf #-} -- | Evaluate the targets of a 'Lens' or 'Traversal' according into a -- data structure according to a given 'Strategy' in parallel. -- -- @'parTraversable' = 'parOf' 'traverse'@ -- -- @ -- 'parOf' :: 'Lens'' s a -> 'Strategy' a -> 'Strategy' s -- 'parOf' :: 'Traversal'' s a -> 'Strategy' a -> 'Strategy' s -- 'parOf' :: ((a -> 'Eval' a) -> s -> 'Eval' s) -> 'Strategy' a -> 'Strategy' s -- @ parOf :: LensLike' Eval s a -> Strategy a -> Strategy s #if MIN_VERSION_parallel(3,2,0) parOf l s = l (rparWith s) #else parOf l s = l (rpar `dot` s) #endif {-# INLINE parOf #-} -- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to -- first evaluates its argument according to a given 'Strategy' /before/ proceeding. -- -- @ -- 'after' 'rdeepseq' 'traverse' :: 'Traversable' t => 'Strategy' a -> 'Strategy' [a] -- @ after :: Strategy s -> LensLike f s t a b -> LensLike f s t a b after s l f = l f $| s {-# INLINE after #-} -- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to -- evaluate its argument according to a given 'Strategy' /in parallel with/ evaluating. -- -- @ -- 'throughout' 'rdeepseq' 'traverse' :: 'Traversable' t => 'Strategy' a -> 'Strategy' [a] -- @ throughout :: Strategy s -> LensLike f s t a b -> LensLike f s t a b throughout s l f = l f $|| s {-# INLINE throughout #-} lens-3.10/src/Control/Seq/0000755000000000000000000000000012226700613013522 5ustar0000000000000000lens-3.10/src/Control/Seq/Lens.hs0000644000000000000000000000153112226700613014757 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Seq.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A 'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. ---------------------------------------------------------------------------- module Control.Seq.Lens ( seqOf ) where import Control.Lens import Control.Seq import Data.Monoid -- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso', -- 'Getter' or 'Fold' according to the given strategy. -- -- @'seqFoldable' = 'seqOf' 'folded'@ seqOf :: Getting (Endo [a]) s a -> Strategy a -> Strategy s seqOf l s = seqList s . toListOf l {-# INLINE seqOf #-} lens-3.10/src/Data/0000755000000000000000000000000012226700613012223 5ustar0000000000000000lens-3.10/src/Data/Array/0000755000000000000000000000000012226700613013301 5ustar0000000000000000lens-3.10/src/Data/Array/Lens.hs0000644000000000000000000000214012226700613014533 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, Rank2Types, LiberalTypeSynonyms -- ---------------------------------------------------------------------------- module Data.Array.Lens ( -- * Setters ixmapped ) where import Control.Lens import Data.Array.IArray hiding (index) -- | This 'setter' can be used to derive a new 'IArray' from an old 'IAarray' by -- applying a function to each of the indices to look it up in the old 'IArray'. -- -- This is a /contravariant/ 'Setter'. -- -- @ -- 'ixmap' ≡ 'over' '.' 'ixmapped' -- 'ixmapped' ≡ 'setting' '.' 'ixmap' -- 'over' ('ixmapped' b) f arr '!' i ≡ arr '!' f i -- 'bounds' ('over' ('ixmapped' b) f arr) ≡ b -- @ ixmapped :: (IArray a e, Ix i, Ix j) => (i,i) -> IndexPreservingSetter (a j e) (a i e) i j ixmapped = setting . ixmap {-# INLINE ixmapped #-} lens-3.10/src/Data/Bits/0000755000000000000000000000000012226700613013124 5ustar0000000000000000lens-3.10/src/Data/Bits/Lens.hs0000644000000000000000000001606312226700613014367 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Bits.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : LiberalTypeSynonyms -- ---------------------------------------------------------------------------- module Data.Bits.Lens ( (.|.~), (.&.~), (<.|.~), (<.&.~) , (.|.=), (.&.=), (<.|.=), (<.&.=) , bitAt , bits , byteAt ) where import Control.Lens import Control.Monad.State import Data.Bits import Data.Functor import Data.Word -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Data.Word infixr 4 .|.~, .&.~, <.|.~, <.&.~ infix 4 .|.=, .&.=, <.|.=, <.&.= -- | Bitwise '.|.' the target(s) of a 'Lens' or 'Setter'. -- -- >>> _2 .|.~ 6 $ ("hello",3) -- ("hello",7) -- -- @ -- ('.|.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t -- ('.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t -- ('.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t -- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t -- @ (.|.~):: Bits a => ASetter s t a a -> a -> s -> t l .|.~ n = over l (.|. n) {-# INLINE (.|.~) #-} -- | Bitwise '.&.' the target(s) of a 'Lens' or 'Setter'. -- -- >>> _2 .&.~ 7 $ ("hello",254) -- ("hello",6) -- -- @ -- ('.&.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t -- ('.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t -- ('.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t -- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t -- @ (.&.~) :: Bits a => ASetter s t a a -> a -> s -> t l .&.~ n = over l (.&. n) {-# INLINE (.&.~) #-} -- | Modify the target(s) of a 'Lens'', 'Setter'' or 'Traversal'' by computing its bitwise '.&.' with another value. -- -- >>> execState (do _1 .&.= 15; _2 .&.= 3) (7,7) -- (7,3) -- -- @ -- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Setter'' s a -> a -> m () -- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Iso'' s a -> a -> m () -- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Lens'' s a -> a -> m () -- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Traversal'' s a -> a -> m () -- @ (.&.=):: (MonadState s m, Bits a) => ASetter' s a -> a -> m () l .&.= a = modify (l .&.~ a) {-# INLINE (.&.=) #-} -- | Modify the target(s) of a 'Lens'', 'Setter' or 'Traversal' by computing its bitwise '.|.' with another value. -- -- >>> execState (do _1 .|.= 15; _2 .|.= 3) (7,7) -- (15,7) -- -- @ -- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Setter'' s a -> a -> m () -- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Iso'' s a -> a -> m () -- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Lens'' s a -> a -> m () -- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Traversal'' s a -> a -> m () -- @ (.|.=) :: (MonadState s m, Bits a) => ASetter' s a -> a -> m () l .|.= a = modify (l .|.~ a) {-# INLINE (.|.=) #-} -- | Bitwise '.|.' the target(s) of a 'Lens' (or 'Traversal'), returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.|.~ 6 $ ("hello",3) -- (7,("hello",7)) -- -- @ -- ('<.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) -- ('<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) -- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) -- @ (<.|.~):: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) l <.|.~ n = l <%~ (.|. n) {-# INLINE (<.|.~) #-} -- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.&.~ 7 $ ("hello",254) -- (6,("hello",6)) -- -- @ -- ('<.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) -- ('<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) -- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) -- @ (<.&.~) :: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) l <.&.~ n = l <%~ (.&. n) {-# INLINE (<.&.~) #-} -- | Modify the target(s) of a 'Lens'' (or 'Traversal'') by computing its bitwise '.&.' with another value, -- returning the result (or a monoidal summary of all of the results traversed). -- -- >>> runState (_1 <.&.= 15) (31,0) -- (15,(15,0)) -- -- @ -- ('<.&.=') :: ('MonadState' s m, 'Bits' a) => 'Lens'' s a -> a -> m a -- ('<.&.=') :: ('MonadState' s m, 'Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal'' s a -> a -> m a -- @ (<.&.=):: (MonadState s m, Bits a) => LensLike' ((,)a) s a -> a -> m a l <.&.= b = l <%= (.&. b) {-# INLINE (<.&.=) #-} -- | Modify the target(s) of a 'Lens'', (or 'Traversal') by computing its bitwise '.|.' with another value, -- returning the result (or a monoidal summary of all of the results traversed). -- -- >>> runState (_1 <.|.= 7) (28,0) -- (31,(31,0)) -- -- @ -- ('<.|.=') :: ('MonadState' s m, 'Bits' a) => 'Lens'' s a -> a -> m a -- ('<.|.=') :: ('MonadState' s m, 'Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal'' s a -> a -> m a -- @ (<.|.=) :: (MonadState s m, Bits a) => LensLike' ((,)a) s a -> a -> m a l <.|.= b = l <%= (.|. b) {-# INLINE (<.|.=) #-} -- | This 'Lens' can be used to access the value of the nth bit in a number. -- -- @'bitAt' n@ is only a legal 'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@. -- -- >>> 16^.bitAt 4 -- True -- -- >>> 15^.bitAt 4 -- False -- -- >>> 15 & bitAt 4 .~ True -- 31 -- -- >>> 16 & bitAt 4 .~ False -- 0 bitAt :: Bits b => Int -> IndexedLens' Int b Bool bitAt n f b = indexed f n (testBit b n) <&> \x -> if x then setBit b n else clearBit b n {-# INLINE bitAt #-} -- | Get the nth byte, counting from the low end. -- -- @'byteAt' n@ is a legal 'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@ -- -- >>> (0xff00 :: Word16)^.byteAt 0 -- 0 -- -- >>> (0xff00 :: Word16)^.byteAt 1 -- 255 -- -- >>> byteAt 1 .~ 0 $ 0xff00 :: Word16 -- 0 -- -- >>> byteAt 0 .~ 0xff $ 0 :: Word16 -- 255 byteAt :: (Integral b, Bits b) => Int -> IndexedLens' Int b Word8 byteAt i f b = back <$> indexed f i (forward b) where back w8 = (fromIntegral w8 `shiftL` (i * 8)) .|. (complement (255 `shiftL` (i * 8)) .&. b) forward = fromIntegral . (.&.) 0xff . flip shiftR (i * 8) -- | Traverse over all bits in a numeric type. -- -- The bit position is available as the index. -- -- >>> toListOf bits (5 :: Word8) -- [True,False,True,False,False,False,False,False] -- -- If you supply this an 'Integer', the result will be an infinite 'Traversal', which -- can be productively consumed, but not reassembled. bits :: (Num b, Bits b) => IndexedTraversal' Int b Bool bits f b = Prelude.foldr step 0 <$> traverse g bs where g n = (,) n <$> indexed f n (testBit b n) bs = Prelude.takeWhile hasBit [0..] hasBit n = complementBit b n /= b -- test to make sure that complementing this bit actually changes the value step (n,True) r = setBit r n step _ r = r {-# INLINE bits #-} lens-3.10/src/Data/ByteString/0000755000000000000000000000000012226700613014315 5ustar0000000000000000lens-3.10/src/Data/ByteString/Lens.hs0000644000000000000000000001125112226700613015552 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Lens ( IsByteString(..) , unpackedBytes , unpackedChars ) where import Control.Lens import Data.Word (Word8) import Data.ByteString as Strict import qualified Data.ByteString.Strict.Lens as Strict import Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Lens as Lazy -- | Traversals for ByteStrings. class IsByteString t where -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a strict or lazy 'ByteString'. -- -- @ -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes' -- 'packedBytes' ≡ 'from' 'unpackedBytes' -- @ packedBytes :: Iso' [Word8] t -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a strict or lazy 'ByteString'. -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- @ -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' -- 'packedChars' ≡ 'from' 'unpackedChars' -- @ packedChars :: Iso' String t -- | Traverse each 'Word8' in a strict or lazy 'ByteString' -- -- -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to the much slower: -- -- @ -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed' -- @ -- -- @ -- 'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool' -- @ bytes :: IndexedTraversal' Int t Word8 bytes = from packedBytes . traversed {-# INLINE bytes #-} -- | Traverse the individual bytes in a strict or lazy 'ByteString' as characters. -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to the much slower: -- -- @ -- 'chars' ≡ 'unpackedChars' '.' 'traversed' -- @ -- -- @ -- 'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool' -- @ chars :: IndexedTraversal' Int t Char chars = from packedChars . traversed {-# INLINE chars #-} -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes -- -- @ -- 'unpackedBytes' ≡ 'from' 'packedBytes' -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' -- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes' -- @ -- -- @ -- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.ByteString' ['Word8'] -- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' ['Word8'] -- @ unpackedBytes :: IsByteString t => Iso' t [Word8] unpackedBytes = from packedBytes {-# INLINE unpackedBytes #-} -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a strict (or lazy) 'ByteString' -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- @ -- 'unpackedChars' ≡ 'from' 'packedChars' -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars' -- @ -- -- @ -- 'unpackedChars' :: 'Iso'' 'Data.ByteString.ByteString' 'String' -- 'unpackedChars' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' 'String' -- @ unpackedChars :: IsByteString t => Iso' t String unpackedChars = from packedChars {-# INLINE unpackedChars #-} instance IsByteString Strict.ByteString where packedBytes = Strict.packedBytes {-# INLINE packedBytes #-} packedChars = Strict.packedChars {-# INLINE packedChars #-} bytes = Strict.bytes {-# INLINE bytes #-} chars = Strict.chars {-# INLINE chars #-} instance IsByteString Lazy.ByteString where packedBytes = Lazy.packedBytes {-# INLINE packedBytes #-} packedChars = Lazy.packedChars {-# INLINE packedChars #-} bytes = from packedBytes . traversed {-# INLINE bytes #-} chars = from packedChars . traversed {-# INLINE chars #-} lens-3.10/src/Data/ByteString/Lazy/0000755000000000000000000000000012226700613015234 5ustar0000000000000000lens-3.10/src/Data/ByteString/Lazy/Lens.hs0000644000000000000000000001013712226700613016473 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lazy.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- Lazy 'ByteString' lenses. ---------------------------------------------------------------------------- module Data.ByteString.Lazy.Lens ( packedBytes, unpackedBytes, bytes , packedChars, unpackedChars, chars ) where import Control.Lens import Control.Lens.Internal.ByteString import Data.ByteString.Lazy as Words import Data.ByteString.Lazy.Char8 as Char8 import Data.Word (Word8) import Data.Int (Int64) -- $setup -- >>> :set -XOverloadedStrings -- >>> import Numeric.Lens -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString'. -- -- @ -- 'packedBytes' ≡ 'from' 'unpackedBytes' -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes' -- @ -- -- >>> [104,101,108,108,111]^.packedBytes == Char8.pack "hello" -- True packedBytes :: Iso' [Word8] ByteString packedBytes = iso Words.pack unpackLazy {-# INLINE packedBytes #-} -- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a 'ByteString' into a list of bytes -- -- @ -- 'unpackedBytes' ≡ 'from' 'packedBytes' -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' -- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes' -- @ -- -- >>> "hello"^.packedChars.unpackedBytes -- [104,101,108,108,111] unpackedBytes :: Iso' ByteString [Word8] unpackedBytes = from packedBytes {-# INLINE unpackedBytes #-} -- | Traverse the individual bytes in a 'ByteString'. -- -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to the much slower: -- -- @ -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed' -- @ -- -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False bytes :: IndexedTraversal' Int64 ByteString Word8 bytes = traversedLazy {-# INLINE bytes #-} -- | 'Data.ByteString.Lazy.Char8.pack' (or 'Data.ByteString.Lazy.Char8.unpack') a list of characters into a 'ByteString'. -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- @ -- 'packedChars' ≡ 'from' 'unpackedChars' -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' -- @ -- -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString packedChars = iso Char8.pack unpackLazy8 {-# INLINE packedChars #-} -- | 'Data.ByteString.Lazy.Char8.unpack' (or 'Data.ByteString.Lazy.Char8.pack') a list of characters into a 'ByteString' -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- @ -- 'unpackedChars' ≡ 'from' 'packedChars' -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars' -- @ -- -- >>> [104,101,108,108,111]^.packedBytes.unpackedChars -- "hello" unpackedChars :: Iso' ByteString String unpackedChars = from packedChars {-# INLINE unpackedChars #-} -- | Traverse the individual bytes in a 'ByteString' as characters. -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to: -- -- @ -- 'chars' = 'unpackedChars' '.' 'traversed' -- @ -- -- >>> anyOf chars (== 'h') "hello" -- True chars :: IndexedTraversal' Int64 ByteString Char chars = traversedLazy8 {-# INLINE chars #-} lens-3.10/src/Data/ByteString/Strict/0000755000000000000000000000000012226700613015565 5ustar0000000000000000lens-3.10/src/Data/ByteString/Strict/Lens.hs0000644000000000000000000001003212226700613017016 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Strict.Lens ( packedBytes, unpackedBytes, bytes , packedChars, unpackedChars, chars ) where import Control.Lens import Control.Lens.Internal.ByteString import Data.ByteString as Words import Data.ByteString.Char8 as Char8 import Data.Word -- $setup -- >>> import Control.Lens -- >>> import Numeric.Lens -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' -- -- @ -- 'packedBytes' ≡ 'from' 'unpackedBytes' -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes' -- @ -- -- >>> [104,101,108,108,111]^.packedBytes -- "hello" packedBytes :: Iso' [Word8] ByteString packedBytes = iso Words.pack unpackStrict {-# INLINE packedBytes #-} -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes -- -- @ -- 'unpackedBytes' ≡ 'from' 'packedBytes' -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' -- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes' -- @ -- -- >>> "hello"^.packedChars.unpackedBytes -- [104,101,108,108,111] unpackedBytes :: Iso' ByteString [Word8] unpackedBytes = from packedBytes {-# INLINE unpackedBytes #-} -- | Traverse each 'Word8' in a 'ByteString'. -- -- This 'Traversal' walks the 'ByteString' in a tree-like fashion -- enable zippers to seek to locations in logarithmic time and accelerating -- many monoidal queries, but up to associativity (and constant factors) -- it is equivalent to the much slower: -- -- @ -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed' -- @ -- -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False bytes :: IndexedTraversal' Int ByteString Word8 bytes = traversedStrictTree 0 {-# INLINE bytes #-} -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a 'ByteString' -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- @ -- 'packedChars' ≡ 'from' 'unpackedChars' -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' -- @ -- -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString packedChars = iso Char8.pack unpackStrict8 {-# INLINE packedChars #-} -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a 'ByteString' -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- @ -- 'unpackedChars' ≡ 'from' 'packedChars' -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars' -- @ -- -- >>> [104,101,108,108,111]^.packedBytes.unpackedChars -- "hello" unpackedChars :: Iso' ByteString String unpackedChars = from packedChars {-# INLINE unpackedChars #-} -- | Traverse the individual bytes in a 'ByteString' as characters. -- -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- -- This 'Traversal' walks the 'ByteString' in a tree-like fashion -- enable zippers to seek to locations in logarithmic time and accelerating -- many monoidal queries, but up to associativity (and constant factors) -- it is equivalent to the much slower: -- -- @ -- 'chars' = 'unpackedChars' '.' 'traverse' -- @ -- -- >>> anyOf chars (== 'h') "hello" -- True chars :: IndexedTraversal' Int ByteString Char chars = traversedStrictTree8 0 {-# INLINE chars #-} lens-3.10/src/Data/Complex/0000755000000000000000000000000012226700613013632 5ustar0000000000000000lens-3.10/src/Data/Complex/Lens.hs0000644000000000000000000000724712226700613015101 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Complex.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- Lenses and traversals for complex numbers -- ---------------------------------------------------------------------------- module Data.Complex.Lens ( _realPart , _imagPart , _polar , _magnitude , _phase , _conjugate ) where import Control.Applicative import Control.Lens import Data.Complex -- $setup -- >>> import Debug.SimpleReflect -- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ } -- | Access the 'realPart' of a 'Complex' number. -- -- >>> (a :+ b)^._realPart -- a -- -- >>> a :+ b & _realPart *~ 2 -- a * 2 :+ b -- -- @'_realPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0) _realPart :: Lens' (Complex a) a #else _realPart :: RealFloat a => Lens' (Complex a) a #endif _realPart f (a :+ b) = (:+ b) <$> f a {-# INLINE _realPart #-} -- | Access the 'imagPart' of a 'Complex' number. -- -- >>> (a :+ b)^._imagPart -- b -- -- >>> a :+ b & _imagPart *~ 2 -- a :+ b * 2 -- -- @'_imagPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0) _imagPart :: Lens' (Complex a) a #else _imagPart :: RealFloat a => Lens' (Complex a) a #endif _imagPart f (a :+ b) = (a :+) <$> f b {-# INLINE _imagPart #-} -- | This isn't /quite/ a legal 'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a 'polar' value with 0 'magnitude' and non-zero -- 'phase' as the 'phase' information is lost, or with a negative 'magnitude' -- which flips the 'phase' and retains a positive 'magnitude'. So don't do -- that! -- -- Otherwise, this is a perfectly cromulent 'Lens'. _polar :: RealFloat a => Iso' (Complex a) (a,a) _polar = iso polar (uncurry mkPolar) {-# INLINE _polar #-} -- | Access the 'magnitude' of a 'Complex' number. -- -- >>> (10.0 :+ 20.0) & _magnitude *~ 2 -- 20.0 :+ 40.0 -- -- This isn't /quite/ a legal 'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a negative 'magnitude'. This flips the 'phase' -- and retains a positive 'magnitude'. So don't do that! -- -- Otherwise, this is a perfectly cromulent 'Lens'. -- -- Setting the 'magnitude' of a zero 'Complex' number assumes the 'phase' is 0. _magnitude :: RealFloat a => Lens' (Complex a) a _magnitude f c = setMag <$> f r where setMag r' | r /= 0 = c * (r' / r :+ 0) | otherwise = r' :+ 0 r = magnitude c {-# INLINE _magnitude #-} -- | Access the 'phase' of a 'Complex' number. -- -- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2 -- True -- -- This isn't /quite/ a legal 'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a 'phase' outside the range @(-'pi', 'pi']@. -- The phase is always in that range when queried. So don't do that! -- -- Otherwise, this is a perfectly cromulent 'Lens'. _phase :: RealFloat a => Lens' (Complex a) a _phase f c = setPhase <$> f theta where setPhase theta' = c * cis (theta' - theta) theta = phase c {-# INLINE _phase #-} -- | Access the 'conjugate' of a 'Complex' number. -- -- >>> (2.0 :+ 3.0) & _conjugate . _imagPart -~ 1 -- 2.0 :+ 4.0 -- -- >>> (mkPolar 10.0 2.0 ^. _conjugate . _phase) ≈ (-2.0) -- True _conjugate :: RealFloat a => Iso' (Complex a) (Complex a) _conjugate = involuted conjugate {-# INLINE _conjugate #-} lens-3.10/src/Data/Data/0000755000000000000000000000000012226700613013074 5ustar0000000000000000lens-3.10/src/Data/Data/Lens.hs0000644000000000000000000004004712226700613014336 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Data.Lens -- Copyright : (C) 2012-2013 Edward Kmett, (C) 2006-2012 Neil Mitchell -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2Types -- -- Smart and naïve generic traversals given 'Data' instances. -- -- 'template', 'uniplate', and 'biplate' each build up information about what -- types can be contained within another type to speed up 'Traversal'. -- ---------------------------------------------------------------------------- module Data.Data.Lens ( -- * Generic Traversal template , tinplate , uniplate , biplate -- * Field Accessor Traversal , upon , upon' , onceUpon , onceUpon' -- * Data Traversal , gtraverse ) where 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.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, (!)) import qualified Data.HashSet as S import Data.HashSet (HashSet) import Data.IORef import Data.Monoid import GHC.Exts (realWorld#) #endif {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Use foldl" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens ------------------------------------------------------------------------------- -- Generic Traversal ------------------------------------------------------------------------------- -- | A generic applicative transformation that maps over the immediate subterms. -- -- 'gtraverse' is to 'traverse' what 'gmapM' is to 'mapM' -- -- This really belongs in @Data.Data@. gtraverse :: (Applicative f, Data a) => (forall d. Data d => d -> f d) -> a -> f a gtraverse f = gfoldl (\x y -> x <*> f y) pure {-# INLINE gtraverse #-} ------------------------------------------------------------------------------- -- Naïve Traversal ------------------------------------------------------------------------------- -- | Naïve 'Traversal' using 'Data'. This does not attempt to optimize the traversal. -- -- This is primarily useful when the children are immediately obvious, and for benchmarking. tinplate :: (Data s, Typeable a) => Traversal' s a 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 {-# INLINE step #-} ------------------------------------------------------------------------------- -- Smart Traversal ------------------------------------------------------------------------------- -- | Find every occurrence of a given type @a@ recursively that doesn't require -- passing through something of type @a@ using 'Data', while avoiding traversal -- of areas that cannot contain a value of type @a@. -- -- This is 'uniplate' with a more liberal signature. template :: forall s a. (Data s, Typeable a) => 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 -- type @a@ using 'Data'. -- -- 'uniplate' is a useful default definition for 'Control.Lens.Plated.plate' uniplate :: Data a => Traversal' a a uniplate = template {-# INLINE uniplate #-} -- | '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 #-} ------------------------------------------------------------------------------ -- Automatic Traversal construction from field accessors ------------------------------------------------------------------------------ data FieldException a = FieldException !Int a deriving Typeable instance Show (FieldException a) where showsPrec d (FieldException i _) = showParen (d > 10) $ showString "' instance Typeable a => Exception (FieldException a) lookupon :: Typeable a => LensLike' (Indexing Mutator) 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 Nothing -> Nothing Just (FieldException i a) -> Just (i, Context (\a' -> set (elementOf l i) a' s) a) {-# INLINE lookupon #-} -- | This automatically constructs a 'Traversal'' from an function. -- -- >>> (2,4) & upon fst *~ 5 -- (10,4) -- -- There are however, caveats on how this function can be used! -- -- First, the user supplied function must access only one field of the specified type. That is to say the target -- must be a single element that would be visited by @'holesOnOf' 'template' 'uniplate'@ -- -- Note: this even permits a number of functions to be used directly. -- -- >>> [1,2,3,4] & upon head .~ 0 -- [0,2,3,4] -- -- >>> [1,2,3,4] & upon last .~ 5 -- [1,2,3,5] -- -- >>> [1,2,3,4] ^? upon tail -- Just [2,3,4] -- -- >>> "" ^? upon tail -- Nothing -- -- Accessing parents on the way down to children is okay: -- -- >>> [1,2,3,4] & upon (tail.tail) .~ [10,20] -- [1,2,10,20] -- -- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data' -- -- @'upon' :: ('Data' s, 'Data' a) => (s -> a) -> 'IndexedTraversal'' [Int] s a@ upon :: forall p f s a. (Indexable [Int] p, Applicative f, Data s, Data a) => (s -> a) -> p a (f a) -> s -> f s upon field f s = case lookupon template field s of Nothing -> pure s Just (i, Context k0 a0) -> let go :: [Int] -> Traversal' s a -> (a -> s) -> a -> f s go is l k a = case lookupon (l.uniplate) field s of Nothing -> k <$> indexed f (reverse is) a Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a' in go [i] (elementOf template i) k0 a0 {-# INLINE upon #-} -- | The design of 'onceUpon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. -- 'upon'' provides this additional recursion. -- -- Like 'onceUpon'', 'upon'' trusts the user supplied function more than 'upon' using it directly -- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of -- generating an illegal lens. -- -- >>> upon' (tail.tail) .~ [10,20] $ [1,2,3,4] -- [1,2,10,20] upon' :: forall s a. (Data s, Data a) => (s -> a) -> IndexedLens' [Int] s a upon' field f s = let ~(isn, kn) = case lookupon template field s of Nothing -> (error "upon': no index, not a member", const s) Just (i, Context k0 _) -> go [i] (elementOf template i) k0 go :: [Int] -> Traversal' s a -> (a -> s) -> ([Int], a -> s) go is l k = case lookupon (l.uniplate) field s of Nothing -> (reverse is, k) Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k' in kn <$> indexed f isn (field s) {-# INLINE upon' #-} -- | This automatically constructs a 'Traversal'' from a field accessor. -- -- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexing' 'template')@ or into the list -- returned by @'holesOf' 'template'@. -- -- The design of 'onceUpon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. -- 'upon' provides this additional recursion, but at the expense of performance. -- -- >>> onceUpon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD -- [1,10,20] -- -- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD -- [1,2,10,20] -- -- When in doubt, use 'upon' instead. onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedTraversal' Int s a onceUpon field f s = case lookupon template field s of Nothing -> pure s Just (i, Context k a) -> k <$> indexed f i a {-# INLINE onceUpon #-} -- | This more trusting version of 'upon' uses your function directly as the getter for a 'Lens'. -- -- This means that reading from 'upon'' is considerably faster than 'upon'. -- -- However, you pay for faster access in two ways: -- -- 1. When passed an illegal field accessor, 'upon'' will give you a 'Lens' that quietly violates -- the laws, unlike 'upon', which will give you a legal 'Traversal' that avoids modifying the target. -- -- 2. Modifying with the lens is slightly slower, since it has to go back and calculate the index after the fact. -- -- When given a legal field accessor, the index of the 'Lens' can be used as an offset into -- @'elementOf' ('indexed' 'template')@ or into the list returned by @'holesOf' 'template'@. -- -- When in doubt, use 'upon'' instead. onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> IndexedLens' Int s a onceUpon' field f s = k <$> indexed f i (field s) where ~(i, Context k _) = fromMaybe (error "upon': no index, not a member") (lookupon template field s) {-# INLINE onceUpon' #-} #ifndef SAFE ------------------------------------------------------------------------------- -- Data Box ------------------------------------------------------------------------------- data DataBox = forall a. Data a => DataBox { dataBoxKey :: TypeRep , _dataBoxVal :: a } dataBox :: Data a => a -> DataBox dataBox a = DataBox (typeOf a) a {-# INLINE dataBox #-} -- partial, caught elsewhere sybChildren :: Data a => a -> [DataBox] sybChildren x | isAlgType dt = do c <- dataTypeConstrs dt gmapQ dataBox (fromConstr c `asTypeOf` x) | otherwise = [] where dt = dataTypeOf x {-# INLINE sybChildren #-} ------------------------------------------------------------------------------- -- HitMap ------------------------------------------------------------------------------- type HitMap = HashMap TypeRep (HashSet TypeRep) emptyHitMap :: HitMap emptyHitMap = M.fromList [ (tRational, S.singleton tInteger) , (tInteger, S.empty) ] where tRational = typeOf (undefined :: Rational) tInteger = typeOf (undefined :: Integer ) insertHitMap :: DataBox -> HitMap -> HitMap insertHitMap box hit = fixEq trans (populate box) `mappend` hit where populate :: DataBox -> HitMap populate a = f a M.empty where f (DataBox k v) m | M.member k hit || M.member k m = m | cs <- sybChildren v = fs cs $ M.insert k (S.fromList $ map dataBoxKey cs) m fs [] m = m fs (x:xs) m = fs xs (f x m) 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 fixEq :: Eq a => (a -> a) -> a -> a fixEq f = go where go x | x == x' = x' | otherwise = go x' where x' = f x {-# INLINE fixEq #-} #ifndef HLINT -- | inlineable 'unsafePerformIO' inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-} #endif ------------------------------------------------------------------------------- -- Cache ------------------------------------------------------------------------------- data Cache = Cache HitMap (HashMap TypeRep (HashMap TypeRep (Maybe Follower))) cache :: IORef Cache cache = unsafePerformIO $ newIORef $ Cache emptyHitMap M.empty {-# NOINLINE cache #-} readCacheFollower :: DataBox -> TypeRep -> Maybe Follower readCacheFollower b@(DataBox kb _) ka = inlinePerformIO $ readIORef cache >>= \ (Cache hm m) -> case M.lookup kb m >>= M.lookup ka of Just a -> return a Nothing -> E.try (return $! insertHitMap b hm) >>= \r -> case r of Left SomeException{} -> atomicModifyIORef cache $ \(Cache hm' n) -> (Cache hm' (insert2 kb ka Nothing n), Nothing) Right hm' | fol <- Just (follower kb ka hm') -> atomicModifyIORef cache $ \(Cache _ n) -> (Cache hm' (insert2 kb ka fol n), fol) insert2 :: TypeRep -> TypeRep -> a -> HashMap TypeRep (HashMap TypeRep a) -> HashMap TypeRep (HashMap TypeRep a) insert2 x y v = M.insertWith (const $ M.insert y v) x (M.singleton y v) {-# INLINE insert2 #-} {- readCacheHitMap :: DataBox -> Maybe HitMap readCacheHitMap b@(DataBox kb _) = inlinePerformIO $ readIORef cache >>= \ (Cache hm _) -> case M.lookup kb hm of Just _ -> return $ Just hm Nothing -> E.try (return $! insertHitMap b hm) >>= \r -> case r of Left SomeException{} -> return Nothing Right hm' -> atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hm' follow, Just hm') -} ------------------------------------------------------------------------------- -- Answers ------------------------------------------------------------------------------- data Answer 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 #-} 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 ------------------------------------------------------------------------------- -- 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 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 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 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 Follow -> go s Miss -> pure s {-# INLINE uniplateData #-} ------------------------------------------------------------------------------- -- Follower ------------------------------------------------------------------------------- part :: (a -> Bool) -> HashSet a -> (HashSet a, HashSet a) part p s = (S.filter p s, S.filter (not . p) s) {-# INLINE part #-} type Follower = TypeRep -> Bool follower :: TypeRep -> TypeRep -> HitMap -> Follower follower a b m | S.null hit = const False | S.null miss = const True | 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 lens-3.10/src/Data/Dynamic/0000755000000000000000000000000012226700613013607 5ustar0000000000000000lens-3.10/src/Data/Dynamic/Lens.hs0000644000000000000000000000261212226700613015045 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Dynamic.Lens ( AsDynamic(..) ) where import Control.Exception import Control.Exception.Lens import Control.Lens import Data.Dynamic -- | Any 'Dynamic' can be thrown as an 'Exception' class AsDynamic t where -- | This 'Prism' allows you to traverse the typed value contained in a -- 'Dynamic' where the type required by your function matches that -- of the contents of the 'Dynamic', or construct a 'Dynamic' value -- out of whole cloth. It can also be used to catch or throw a 'Dynamic' -- value as 'SomeException'. -- -- @ -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'Dynamic' a -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'SomeException' a -- @ _Dynamic :: Typeable a => Prism' t a instance AsDynamic Dynamic where _Dynamic = prism' toDyn fromDynamic {-# INLINE _Dynamic #-} instance AsDynamic SomeException where _Dynamic = exception.prism' toDyn fromDynamic {-# INLINE _Dynamic #-} lens-3.10/src/Data/HashSet/0000755000000000000000000000000012226700613013562 5ustar0000000000000000lens-3.10/src/Data/HashSet/Lens.hs0000644000000000000000000000355412226700613015026 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.HashSet.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.HashSet.Lens ( setmapped , setOf ) where import Control.Lens.Getter (Getting, views) import Control.Lens.Setter (setting) import Control.Lens.Type import Data.HashSet as HashSet import Data.Hashable -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | This 'Setter' can be used to change the type of a 'HashSet' by mapping -- the elements to new values. -- -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. setmapped :: (Eq i, Hashable i, Eq j, Hashable j) => IndexPreservingSetter (HashSet i) (HashSet j) i j setmapped = setting HashSet.map {-# INLINE setmapped #-} -- | Construct a set from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. -- -- @ -- 'setOf' :: 'Hashable' a => 'Getter' s a -> s -> 'HashSet' a -- 'setOf' :: ('Eq' a, 'Hashable' a) => 'Fold' s a -> s -> 'HashSet' a -- 'setOf' :: 'Hashable' a => 'Iso'' s a -> s -> 'HashSet' a -- 'setOf' :: 'Hashable' a => 'Lens'' s a -> s -> 'HashSet' a -- 'setOf' :: ('Eq' a, 'Hashable' a) => 'Traversal'' s a -> s -> 'HashSet' a -- @ setOf :: Hashable a => Getting (HashSet a) s a -> s -> HashSet a setOf l = views l HashSet.singleton {-# INLINE setOf #-} lens-3.10/src/Data/IntSet/0000755000000000000000000000000012226700613013431 5ustar0000000000000000lens-3.10/src/Data/IntSet/Lens.hs0000644000000000000000000000362212226700613014671 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntSet.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.IntSet.Lens ( members , setmapped , setOf ) where import Control.Lens import Data.IntSet as IntSet -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of an 'IntSet'. -- -- >>> sumOf members $ setOf folded [1,2,3,4] -- 10 members :: Fold IntSet Int members = folding IntSet.toAscList {-# INLINE members #-} -- | This 'Setter' can be used to change the contents of an 'IntSet' by mapping -- the elements to new values. -- -- Sadly, you can't create a valid 'Traversal' for a 'Set', because the number of -- elements might change but you can manipulate it by reading using 'folded' and -- reindexing it via 'setmapped'. -- -- >>> over setmapped (+1) (fromList [1,2,3,4]) -- fromList [2,3,4,5] setmapped :: IndexPreservingSetter' IntSet Int setmapped = setting IntSet.map {-# INLINE setmapped #-} -- | Construct an 'IntSet' from a 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'. -- -- >>> setOf folded [1,2,3,4] -- fromList [1,2,3,4] -- -- >>> setOf (folded._2) [("hello",1),("world",2),("!!!",3)] -- fromList [1,2,3] -- -- @ -- 'setOf' :: 'Getter' s 'Int' -> s -> 'IntSet' -- 'setOf' :: 'Fold' s 'Int' -> s -> 'IntSet' -- 'setOf' :: 'Iso'' s 'Int' -> s -> 'IntSet' -- 'setOf' :: 'Lens'' s 'Int' -> s -> 'IntSet' -- 'setOf' :: 'Traversal'' s 'Int' -> s -> 'IntSet' -- @ setOf :: Getting IntSet s Int -> s -> IntSet setOf l = views l IntSet.singleton {-# INLINE setOf #-} lens-3.10/src/Data/List/0000755000000000000000000000000012226700613013136 5ustar0000000000000000lens-3.10/src/Data/List/Lens.hs0000644000000000000000000000517112226700613014377 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Traversals for manipulating parts of a list. -- ---------------------------------------------------------------------------- module Data.List.Lens ( prefixed , suffixed , stripSuffix -- * Deprecated , strippingPrefix , strippingSuffix ) where import Control.Monad (guard) import Control.Lens import Data.Functor import Data.List -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- | A 'Prism' stripping a prefix from a list when used as a 'Traversal', or -- prepending that prefix when run backwards: -- -- >>> "preview" ^? prefixed "pre" -- Just "view" -- -- >>> "review" ^? prefixed "pre" -- Nothing -- -- >>> prefixed "pre" # "amble" -- "preamble" prefixed :: Eq a => [a] -> Prism' [a] [a] prefixed ps = prism' (ps ++) (stripPrefix ps) {-# INLINE prefixed #-} -- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or -- prepending that prefix when run backwards: -- -- >>> "review" ^? suffixed "view" -- Just "re" -- -- >>> "review" ^? suffixed "tire" -- Nothing -- -- >>> suffixed ".o" # "hello" -- "hello.o" suffixed :: Eq a => [a] -> Prism' [a] [a] suffixed qs = prism' (++ qs) (stripSuffix qs) {-# INLINE suffixed #-} ------------------------------------------------------------------------------ -- Util ------------------------------------------------------------------------------ stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix qs xs0 = go xs0 zs where zs = drp qs xs0 drp (_:ps) (_:xs) = drp ps xs drp [] xs = xs drp _ [] = [] go (_:xs) (_:ys) = go xs ys go xs [] = zipWith const xs0 zs <$ guard (xs == qs) go [] _ = Nothing -- impossible {-# INLINE stripSuffix #-} -- | This is a deprecated alias for 'prefixed'. strippingPrefix :: Eq a => [a] -> Prism' [a] [a] strippingPrefix = prefixed {-# INLINE strippingPrefix #-} {-# DEPRECATED strippingPrefix "Use 'prefixed'." #-} -- | This is a deprecated alias for 'suffixed'. strippingSuffix :: Eq a => [a] -> Prism' [a] [a] strippingSuffix = suffixed {-# INLINE strippingSuffix #-} {-# DEPRECATED strippingSuffix "Use 'suffixed'." #-} lens-3.10/src/Data/List/Split/0000755000000000000000000000000012226700613014231 5ustar0000000000000000lens-3.10/src/Data/List/Split/Lens.hs0000644000000000000000000001604212226700613015471 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ---------------------------------------------------------------------------- -- | -- Module : Data.List.Split.Lens -- Copyright : (C) 2012-2013 Edward Kmett, Alexander Altman -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- Lenses for working with Data.List.Split -- ---------------------------------------------------------------------------- module Data.List.Split.Lens ( -- * Splitting Folds splitting , splittingOn , splittingOneOf , splittingWhen , endingBy , endingByOneOf , wordingBy , liningBy , chunking , splittingPlaces , splittingPlacesBlanks -- * Lenses for 'Splitter' Internals , delimiters , delimiting , condensing , keepInitialBlanks , keepFinalBlanks ) where import Control.Lens import Data.Monoid import Data.List.Split import Data.List.Split.Internals -- $setup -- >>> import Control.Lens -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' according to the given splitting strategy. -- -- @ -- 'splitting' :: 'Splitter' a -> 'Fold' s a -> 'Fold' s [a] -- @ splitting :: Splitter a -> Getting (Endo [a]) s a -> Fold s [a] splitting s l f = coerce . traverse f . split s . toListOf l {-# INLINE splitting #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' on the given delimiter. -- -- Equivalent to @'splitting' '.' 'dropDelims' '.' 'onSublist'@. -- -- @ -- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ splittingOn :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] splittingOn s l f = coerce . traverse f . splitOn s . toListOf l {-# INLINE splittingOn #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' on any of the given elements. -- -- Equivalent to @'splitting' '.' 'dropDelims' '.' 'oneOf'@. -- -- @ -- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ splittingOneOf :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] splittingOneOf s l f = coerce . traverse f . splitOneOf s . toListOf l {-# INLINE splittingOneOf #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' on elements satisfying the given predicate. -- -- Equivalent to @'splitting' '.' 'dropDelims' '.' 'whenElt'@. -- -- @ -- 'splittingWhen' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] -- @ splittingWhen :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] splittingWhen s l f = coerce . traverse f . splitWhen s . toListOf l {-# INLINE splittingWhen #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks terminated by the given delimiter. -- -- Equivalent to @'splitting' '.' 'dropDelims' '.' 'onSublist'@. -- -- @ -- 'endingBy' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ endingBy :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] endingBy s l f = coerce . traverse f . endBy s . toListOf l {-# INLINE endingBy #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks terminated by any of the given elements. -- -- Equivalent to @'splitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'oneOf'@. -- -- @ -- 'endingByOneOf' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ endingByOneOf :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] endingByOneOf s l f = coerce . traverse f . endByOneOf s . toListOf l {-# INLINE endingByOneOf #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into "words", with word boundaries indicated by the given predicate. -- -- Equivalent to @'splitting' '.' 'dropBlanks' '.' 'dropDelims' '.' 'whenElt'@. -- -- @ -- 'wordingBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] -- @ wordingBy :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] wordingBy s l f = coerce . traverse f . wordsBy s . toListOf l {-# INLINE wordingBy #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into "lines", with line boundaries indicated by the given predicate. -- -- Equivalent to @'splitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'whenElt'@. -- -- @ -- 'liningBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] -- @ liningBy :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] liningBy s l f = coerce . traverse f . linesBy s . toListOf l {-# INLINE liningBy #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into length-@n@ pieces. -- -- @ -- 'chunking' :: 'Int' -> 'Fold' s a -> 'Fold' s [a] -- @ chunking :: Int -- ^ @n@ -> Getting (Endo [a]) s a -> Fold s [a] chunking s l f = coerce . traverse f . chunksOf s . toListOf l {-# INLINE chunking #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks of the given lengths, . -- -- @ -- 'splittingPlaces' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] -- @ splittingPlaces :: Integral n => [n] -> Getting (Endo [a]) s a -> Fold s [a] splittingPlaces s l f = coerce . traverse f . splitPlaces s . toListOf l {-# INLINE splittingPlaces #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks of the given lengths. Unlike 'splittingPlaces', the output 'Fold' will always be the same length as the first input argument. -- -- @ -- 'splittingPlacesBlanks' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] -- @ splittingPlacesBlanks :: Integral n => [n] -> Getting (Endo [a]) s a -> Fold s [a] splittingPlacesBlanks s l f = coerce . traverse f . splitPlacesBlanks s . toListOf l {-# INLINE splittingPlacesBlanks #-} -- | Modify or retrieve the list of delimiters for a 'Splitter'. delimiters :: Lens (Splitter a) (Splitter b) [a -> Bool] [b -> Bool] delimiters f s@Splitter { delimiter = Delimiter ds } = f ds <&> \ds' -> s { delimiter = Delimiter ds' } {-# INLINE delimiters #-} -- | Modify or retrieve the policy for what a 'Splitter' to do with delimiters. delimiting :: Lens' (Splitter a) DelimPolicy delimiting f s@Splitter { delimPolicy = p } = f p <&> \p' -> s { delimPolicy = p' } {-# INLINE delimiting #-} -- | Modify or retrieve the policy for what a 'Splitter' should about consecutive delimiters. condensing :: Lens' (Splitter a) CondensePolicy condensing f s@Splitter { condensePolicy = p } = f p <&> \p' -> s { condensePolicy = p' } {-# INLINE condensing #-} -- | Modify or retrieve the policy for whether a 'Splitter' should drop an initial blank. keepInitialBlanks :: Lens' (Splitter a) Bool keepInitialBlanks f s@Splitter { initBlankPolicy = p } = f (keeps p) <&> \p' -> s { initBlankPolicy = end p' } {-# INLINE keepInitialBlanks #-} -- | Modify or retrieve the policy for whether a 'Splitter' should drop a final blank. keepFinalBlanks :: Lens' (Splitter a) Bool keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = f (keeps p) <&> \p' -> s { finalBlankPolicy = end p' } {-# INLINE keepFinalBlanks #-} -- utilities end :: Bool -> EndPolicy end True = KeepBlank end False = DropBlank {-# INLINE end #-} keeps :: EndPolicy -> Bool keeps KeepBlank = True keeps DropBlank = False {-# INLINE keeps #-} lens-3.10/src/Data/Sequence/0000755000000000000000000000000012226700613013773 5ustar0000000000000000lens-3.10/src/Data/Sequence/Lens.hs0000644000000000000000000000613612226700613015236 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Sequence.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Sequence.Lens ( viewL, viewR , sliced, slicedTo, slicedFrom ) where import Control.Applicative import Control.Lens import Data.Monoid import Data.Sequence as Seq -- $setup -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- * Sequence isomorphisms -- | A 'Seq' is isomorphic to a 'ViewL' -- -- @'viewl' m ≡ m '^.' 'viewL'@ -- -- >>> Seq.fromList [a,b,c] ^. viewL -- a :< fromList [b,c] -- -- >>> Seq.empty ^. viewL -- EmptyL -- -- >>> EmptyL ^. from viewL -- fromList [] -- -- >>> review viewL $ a :< fromList [b,c] -- fromList [a,b,c] viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) viewL = iso viewl $ \ xs -> case xs of EmptyL -> mempty a :< as -> a Seq.<| as {-# INLINE viewL #-} -- | A 'Seq' is isomorphic to a 'ViewR' -- -- @'viewr' m ≡ m '^.' 'viewR'@ -- -- >>> Seq.fromList [a,b,c] ^. viewR -- fromList [a,b] :> c -- -- >>> Seq.empty ^. viewR -- EmptyR -- -- >>> EmptyR ^. from viewR -- fromList [] -- -- >>> review viewR $ fromList [a,b] :> c -- fromList [a,b,c] viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) viewR = iso viewr $ \xs -> case xs of EmptyR -> mempty as :> a -> as Seq.|> a {-# INLINE viewR #-} -- | Traverse the first @n@ elements of a 'Seq' -- -- >>> fromList [a,b,c,d,e] ^.. slicedTo 2 -- [a,b] -- -- >>> fromList [a,b,c,d,e] & slicedTo 2 %~ f -- fromList [f a,f b,c,d,e] -- -- >>> fromList [a,b,c,d,e] & slicedTo 10 .~ x -- fromList [x,x,x,x,x] slicedTo :: Int -> IndexedTraversal' Int (Seq a) a slicedTo n f m = case Seq.splitAt n m of (l,r) -> (>< r) <$> itraverse (indexed f) l {-# INLINE slicedTo #-} -- | Traverse all but the first @n@ elements of a 'Seq' -- -- >>> fromList [a,b,c,d,e] ^.. slicedFrom 2 -- [c,d,e] -- -- >>> fromList [a,b,c,d,e] & slicedFrom 2 %~ f -- fromList [a,b,f c,f d,f e] -- -- >>> fromList [a,b,c,d,e] & slicedFrom 10 .~ x -- fromList [a,b,c,d,e] slicedFrom :: Int -> IndexedTraversal' Int (Seq a) a slicedFrom n f m = case Seq.splitAt n m of (l,r) -> (l ><) <$> itraverse (indexed f . (+n)) r {-# INLINE slicedFrom #-} -- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' -- -- >>> fromList [a,b,c,d,e] & sliced 1 3 %~ f -- fromList [a,f b,f c,d,e] -- >>> fromList [a,b,c,d,e] ^.. sliced 1 3 -- [f b,f c] -- -- >>> fromList [a,b,c,d,e] & sliced 1 3 .~ x -- fromList [a,x,x,b,e] sliced :: Int -> Int -> IndexedTraversal' Int (Seq a) a sliced i j f s = case Seq.splitAt i s of (l,mr) -> case Seq.splitAt (j-i) mr of (m, r) -> itraverse (indexed f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-} lens-3.10/src/Data/Set/0000755000000000000000000000000012226700613012756 5ustar0000000000000000lens-3.10/src/Data/Set/Lens.hs0000644000000000000000000000350512226700613014216 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Set.Lens ( setmapped , setOf ) where import Control.Lens.Getter ( Getting, views ) import Control.Lens.Setter ( setting ) import Control.Lens.Type import Data.Set as Set -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | This 'Setter' can be used to change the type of a 'Set' by mapping -- the elements to new values. -- -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. -- -- >>> over setmapped (+1) (fromList [1,2,3,4]) -- fromList [2,3,4,5] setmapped :: (Ord i, Ord j) => IndexPreservingSetter (Set i) (Set j) i j setmapped = setting Set.map {-# INLINE setmapped #-} -- | Construct a set from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. -- -- >>> setOf folded ["hello","world"] -- fromList ["hello","world"] -- -- >>> setOf (folded._2) [("hello",1),("world",2),("!!!",3)] -- fromList [1,2,3] -- -- @ -- 'setOf' :: 'Getter' s a -> s -> 'Set' a -- 'setOf' :: 'Ord' a => 'Fold' s a -> s -> 'Set' a -- 'setOf' :: 'Iso'' s a -> s -> 'Set' a -- 'setOf' :: 'Lens'' s a -> s -> 'Set' a -- 'setOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Set' a -- @ setOf :: Getting (Set a) s a -> s -> Set a setOf l = views l Set.singleton {-# INLINE setOf #-} lens-3.10/src/Data/Text/0000755000000000000000000000000012226700613013147 5ustar0000000000000000lens-3.10/src/Data/Text/Lens.hs0000644000000000000000000000427712226700613014416 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lens ( IsText(..), unpacked ) where import Control.Lens import Data.Text as Strict import qualified Data.Text.Strict.Lens as Strict import Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.Lens as Lazy import Data.Text.Lazy.Builder -- | Traversals for strict or lazy 'Text' class IsText t where -- | This isomorphism can be used to 'pack' (or 'unpack') strict or lazy 'Text'. -- -- @ -- 'pack' x ≡ x '^.' 'packed' -- 'unpack' x ≡ x '^.' 'from' 'packed' -- 'packed' ≡ 'from' 'unpacked' -- @ packed :: Iso' String t -- | Convert between strict or lazy 'Text' and a 'Builder'. -- -- @ -- 'fromText' x ≡ x '^.' 'builder' -- @ builder :: Iso' t Builder -- | Traverse the individual characters in strict or lazy 'Text'. -- -- @ -- 'text' = 'unpacked' . 'traversed' -- @ text :: IndexedTraversal' Int t Char text = unpacked . traversed {-# INLINE text #-} -- | This isomorphism can be used to 'unpack' (or 'pack') both strict or lazy 'Text'. -- -- @ -- 'unpack' x ≡ x '^.' 'unpacked' -- 'pack' x ≡ x '^.' 'from' 'unpacked' -- @ -- -- This 'Iso' is provided for notational convenience rather than out of great need, since -- -- @ -- 'unpacked' ≡ 'from' 'packed' -- @ -- unpacked :: IsText t => Iso' t String unpacked = from packed {-# INLINE unpacked #-} instance IsText Strict.Text where packed = Strict.packed {-# INLINE packed #-} builder = Strict.builder {-# INLINE builder #-} text = Strict.text {-# INLINE text #-} instance IsText Lazy.Text where packed = Lazy.packed {-# INLINE packed #-} builder = Lazy.builder {-# INLINE builder #-} text = Lazy.text {-# INLINE text #-} lens-3.10/src/Data/Text/Lazy/0000755000000000000000000000000012226700613014066 5ustar0000000000000000lens-3.10/src/Data/Text/Lazy/Lens.hs0000644000000000000000000000404512226700613015326 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lazy.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lazy.Lens ( packed, unpacked , text , builder ) where import Control.Lens import Data.Text.Lazy import Data.Text.Lazy.Builder -- $setup -- >>> :set -XOverloadedStrings -- | This isomorphism can be used to 'pack' (or 'unpack') lazy 'Text'. -- -- >>> "hello"^.packed -- :: Text -- "hello" -- -- @ -- 'pack' x ≡ x '^.' 'packed' -- 'unpack' x ≡ x '^.' 'from' 'packed' -- 'packed' ≡ 'from' 'unpacked' -- @ packed :: Iso' String Text packed = iso pack unpack {-# INLINE packed #-} -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'. -- -- >>> "hello"^.unpacked -- :: String -- "hello" -- -- @ -- 'pack' x ≡ x '^.' 'from' 'unpacked' -- 'unpack' x ≡ x '^.' 'packed' -- @ -- -- This 'Iso' is provided for notational convenience rather than out of great need, since -- -- @ -- 'unpacked' ≡ 'from' 'packed' -- @ unpacked :: Iso' Text String unpacked = iso unpack pack {-# INLINE unpacked #-} -- | Convert between lazy 'Text' and 'Builder' . -- -- @ -- 'fromLazyText' x ≡ x '^.' 'builder' -- 'toLazyText' x ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder builder = iso fromLazyText toLazyText {-# INLINE builder #-} -- | Traverse the individual characters in a 'Text'. -- -- >>> anyOf text (=='c') "chello" -- True -- -- @ -- 'text' = 'unpacked' . 'traversed' -- @ -- -- When the type is unambiguous, you can also use the more general 'each'. -- -- @ -- 'text' ≡ 'each' -- @ text :: IndexedTraversal' Int Text Char text = unpacked . traversed {-# INLINE text #-} lens-3.10/src/Data/Text/Strict/0000755000000000000000000000000012226700613014417 5ustar0000000000000000lens-3.10/src/Data/Text/Strict/Lens.hs0000644000000000000000000000415212226700613015656 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Strict.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Strict.Lens ( packed, unpacked , builder , text ) where import Control.Lens import Data.Text import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder -- $setup -- >>> :set -XOverloadedStrings -- | This isomorphism can be used to 'pack' (or 'unpack') strict 'Text'. -- -- -- >>> "hello"^.packed -- :: Text -- "hello" -- -- @ -- 'pack' x ≡ x '^.' 'packed' -- 'unpack' x ≡ x '^.' 'from' 'packed' -- 'packed' ≡ 'from' 'unpacked' -- 'packed' ≡ 'iso' 'pack' 'unpack' -- @ packed :: Iso' String Text packed = iso pack unpack {-# INLINE packed #-} -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'. -- -- >>> "hello"^.unpacked -- :: String -- "hello" -- -- This 'Iso' is provided for notational convenience rather than out of great need, since -- -- @ -- 'unpacked' ≡ 'from' 'packed' -- @ -- -- @ -- 'pack' x ≡ x '^.' 'from' 'unpacked' -- 'unpack' x ≡ x '^.' 'packed' -- 'unpacked' ≡ 'iso' 'unpack' 'pack' -- @ unpacked :: Iso' Text String unpacked = iso unpack pack -- | Convert between strict 'Text' and 'Builder' . -- -- @ -- 'fromText' x ≡ x '^.' 'builder' -- 'toStrict' ('toLazyText' x) ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder builder = iso fromText (toStrict . toLazyText) {-# INLINE builder #-} -- | Traverse the individual characters in strict 'Text'. -- -- >>> anyOf text (=='o') "hello" -- True -- -- When the type is unambiguous, you can also use the more general 'each'. -- -- @ -- 'text' ≡ 'unpacked' . 'traversed' -- 'text' ≡ 'each' -- @ text :: IndexedTraversal' Int Text Char text = unpacked . traversed {-# INLINE text #-} lens-3.10/src/Data/Tree/0000755000000000000000000000000012226700613013122 5ustar0000000000000000lens-3.10/src/Data/Tree/Lens.hs0000644000000000000000000000164612226700613014366 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MTPCs -- ---------------------------------------------------------------------------- module Data.Tree.Lens ( root , branches ) where import Control.Lens import Data.Functor import Data.Tree -- | A 'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 [] -- 42 root :: Lens' (Tree a) a root f (Node a as) = (`Node` as) <$> f a {-# INLINE root #-} -- | A 'Lens' returning the direct descendants of the root of a 'Tree' -- -- @'view' 'branches' ≡ 'subForest'@ branches :: Lens' (Tree a) [Tree a] branches f (Node a as) = Node a <$> f as {-# INLINE branches #-} lens-3.10/src/Data/Typeable/0000755000000000000000000000000012226700613013770 5ustar0000000000000000lens-3.10/src/Data/Typeable/Lens.hs0000644000000000000000000000224112226700613015224 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Typeable.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Typeable.Lens ( _cast , _gcast ) where import Control.Applicative import Control.Lens import Data.Typeable import Data.Maybe -- | A 'Traversal'' for working with a 'cast' of a 'Typeable' value. _cast :: (Typeable s, Typeable a) => Traversal' s a _cast f s = case cast s of Just a -> fromMaybe (error "_cast: recast failed") . cast <$> f a Nothing -> pure s {-# INLINE _cast #-} -- | A 'Traversal'' for working with a 'gcast' of a 'Typeable' value. _gcast :: (Typeable s, Typeable a) => Traversal' (c s) (c a) _gcast f s = case gcast s of Just a -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a Nothing -> pure s {-# INLINE _gcast #-} lens-3.10/src/Data/Vector/0000755000000000000000000000000012226700613013465 5ustar0000000000000000lens-3.10/src/Data/Vector/Lens.hs0000644000000000000000000000547612226700613014736 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- -- This module provides lenses and traversals for working with generic -- vectors. ------------------------------------------------------------------------------- module Data.Vector.Lens ( toVectorOf -- * Isomorphisms , vector , forced -- * Lenses , sliced -- * Traversal of individual indices , ordinals ) where import Control.Applicative import Control.Lens import Data.Vector as Vector hiding (zip, filter, indexed) import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) import Data.List (nub) import Data.Monoid -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting -- at index @i@ from a 'Lens'. -- -- This is only a valid 'Lens' if you do not change the length of the -- resulting 'Vector'. -- -- Attempting to return a longer or shorter vector will result in -- violations of the 'Lens' laws. -- -- >>> Vector.fromList [1..10] ^. sliced 2 5 -- fromList [3,4,5,6,7] -- -- >>> Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0 -- fromList [1,2,0,0,0,0,0,8,9,10] sliced :: Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Lens' (Vector a) (Vector a) sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'. -- -- >>> toVectorOf both (8,15) -- fromList [8,15] toVectorOf :: Getting (Endo [a]) s a -> s -> Vector a toVectorOf l s = fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back) -- -- >>> [1,2,3] ^. vector -- fromList [1,2,3] -- -- >>> [1,2,3] ^. vector . from vector -- [1,2,3] -- -- >>> Vector.fromList [0,8,15] ^. from vector . vector -- fromList [0,8,15] vector :: Iso [a] [b] (Vector a) (Vector b) vector = iso fromList toList {-# INLINE vector #-} -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b) forced = iso force force {-# INLINE forced #-} -- | This 'Traversal' will ignore any duplicates in the supplied list -- of indices. -- -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: [Int] -> IndexedTraversal' Int (Vector a) a ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ nub $ filter (\i -> 0 <= i && i < l) is where l = length v {-# INLINE ordinals #-} lens-3.10/src/Data/Vector/Generic/0000755000000000000000000000000012226700613015041 5ustar0000000000000000lens-3.10/src/Data/Vector/Generic/Lens.hs0000644000000000000000000000673712226700613016313 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Generic.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- -- This module provides lenses and traversals for working with generic -- vectors. ------------------------------------------------------------------------------- module Data.Vector.Generic.Lens ( toVectorOf -- * Isomorphisms , forced , vector , asStream , asStreamR , cloned -- * Lenses , sliced -- * Traversal of individual indices , ordinals ) where import Control.Applicative import Control.Lens import Data.List (nub) import Data.Monoid import Data.Vector.Generic as V hiding (zip, filter, indexed) import Data.Vector.Fusion.Stream (Stream) import Data.Vector.Generic.New (New) import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) -- $setup -- >>> import Data.Vector as Vector -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting -- at index @i@ from a 'Lens'. -- -- This is only a valid 'Lens' if you do not change the length of the -- resulting 'Vector'. -- -- Attempting to return a longer or shorter vector will result in -- violations of the 'Lens' laws. -- -- >>> Vector.fromList [1..10] ^. sliced 2 5 -- fromList [3,4,5,6,7] -- -- >>> Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0 -- fromList [1,2,0,0,0,0,0,8,9,10] sliced :: Vector v a => Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Lens' (v a) (v a) sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (V.toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'. -- -- >>> toVectorOf both (8,15) :: Vector.Vector Int -- fromList [8,15] toVectorOf :: Vector v a => Getting (Endo [a]) s a -> s -> v a toVectorOf l s = fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back.) -- -- >>> [1,2,3] ^. vector :: Vector.Vector Int -- fromList [1,2,3] -- -- >>> Vector.fromList [0,8,15] ^. from vector -- [0,8,15] vector :: Vector v a => Iso' [a] (v a) vector = iso fromList V.toList {-# INLINE vector #-} -- | Convert a 'Vector' to a finite 'Stream' (or back.) asStream :: Vector v a => Iso' (v a) (Stream a) asStream = iso stream unstream {-# INLINE asStream #-} -- | Convert a 'Vector' to a finite 'Stream' from right to left (or -- back.) asStreamR :: Vector v a => Iso' (v a) (Stream a) asStreamR = iso streamR unstreamR {-# INLINE asStreamR #-} -- | Convert a 'Vector' back and forth to an initializer that when run -- produces a copy of the 'Vector'. cloned :: Vector v a => Iso' (v a) (New v a) cloned = iso clone new {-# INLINE cloned #-} -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. forced :: Vector v a => Iso' (v a) (v a) forced = involuted force {-# INLINE forced #-} -- | This 'Traversal' will ignore any duplicates in the supplied list -- of indices. -- -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: Vector v a => [Int] -> IndexedTraversal' Int (v a) a ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ nub $ filter (\i -> 0 <= i && i < l) is where l = length v {-# INLINE ordinals #-} lens-3.10/src/Generics/0000755000000000000000000000000012226700613013111 5ustar0000000000000000lens-3.10/src/Generics/Deriving/0000755000000000000000000000000012226700613014660 5ustar0000000000000000lens-3.10/src/Generics/Deriving/Lens.hs0000644000000000000000000000714512226700613016124 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Generics.Deriving.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : GHC -- -- 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: -- -- > 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. ---------------------------------------------------------------------------- module Generics.Deriving.Lens ( -- * Isomorphisms for @GHC.Generics@ generic , generic1 -- * Generic Traversal , tinplate , GTraversal ) where import Control.Applicative import Control.Lens import Data.Maybe (fromJust) import Data.Typeable import qualified Generics.Deriving as Generic import Generics.Deriving hiding (from, to) -- $setup -- >>> :set -XNoOverloadedStrings -- | Convert from the data type to its representation (or back) -- -- >>> "hello"^.generic.from generic :: String -- "hello" generic :: Generic a => Iso' a (Generic.Rep a b) generic = iso Generic.from Generic.to {-# INLINE generic #-} -- | Convert from the data type to its representation (or back) generic1 :: Generic1 f => Iso' (f a) (Rep1 f a) generic1 = iso from1 to1 {-# INLINE generic1 #-} -- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurrence -- of something 'Typeable' anywhere in a container. -- -- >>> allOf tinplate (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"]) -- True -- -- >>> mapMOf_ tinplate putStrLn ("hello",[(2 :: Int, "world!")]) -- hello -- world! tinplate :: (Generic a, GTraversal (Generic.Rep a), Typeable b) => Traversal' a b tinplate = generic . tinplated True {-# INLINE tinplate #-} maybeArg1Of :: Maybe c -> (c -> d) -> Maybe c maybeArg1Of = const {-# INLINE maybeArg1Of #-} -- | Used to traverse 'Generic' data by 'uniplate'. class GTraversal f where tinplated :: Typeable b => Bool -> Traversal' (f a) b instance (Generic a, GTraversal (Generic.Rep a), Typeable a) => GTraversal (K1 i a) where tinplated rec f (K1 a) = case cast a `maybeArg1Of` f of Just b -> K1 . fromJust . cast <$> f b Nothing | rec -> K1 <$> fmap generic (tinplated False) f a | otherwise -> pure $ K1 a {-# INLINE tinplated #-} instance GTraversal U1 where tinplated _ _ U1 = pure U1 {-# INLINE tinplated #-} instance (GTraversal f, GTraversal g) => GTraversal (f :*: g) where tinplated _ f (x :*: y) = (:*:) <$> tinplated True f x <*> tinplated True f y {-# INLINE tinplated #-} instance (GTraversal f, GTraversal g) => GTraversal (f :+: g) where tinplated _ f (L1 x) = L1 <$> tinplated True f x tinplated _ f (R1 x) = R1 <$> tinplated True f x {-# INLINE tinplated #-} instance GTraversal a => GTraversal (M1 i c a) where tinplated rec f (M1 x) = M1 <$> tinplated rec f x {-# INLINE tinplated #-} -- ? instance (Traversable f, GTraversal g) => GTraversal (f :.: g) where tinplated _ f (Comp1 fgp) = Comp1 <$> traverse (tinplated True f) fgp {-# INLINE tinplated #-} lens-3.10/src/GHC/0000755000000000000000000000000012226700613011753 5ustar0000000000000000lens-3.10/src/GHC/Generics/0000755000000000000000000000000012226700613013512 5ustar0000000000000000lens-3.10/src/GHC/Generics/Lens.hs0000644000000000000000000000244412226700613014753 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : GHC -- -- Note: @GHC.Generics@ 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: -- -- > import Control.Lens hiding (Rep) -- > import GHC.Generics hiding (from, to) -- -- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to' from @GHC.Generics@, -- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@ -- in code that uses generics. -- -- This module provides compatibility with older GHC versions by using the -- -- package. ---------------------------------------------------------------------------- module GHC.Generics.Lens ( module Generics.Deriving.Lens ) where import Generics.Deriving.Lens lens-3.10/src/Language/0000755000000000000000000000000012226700613013075 5ustar0000000000000000lens-3.10/src/Language/Haskell/0000755000000000000000000000000012226700613014460 5ustar0000000000000000lens-3.10/src/Language/Haskell/TH/0000755000000000000000000000000012226700613014773 5ustar0000000000000000lens-3.10/src/Language/Haskell/TH/Lens.hs0000644000000000000000000001235212226700613016233 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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 lens-3.10/src/Numeric/0000755000000000000000000000000012226700613012754 5ustar0000000000000000lens-3.10/src/Numeric/Lens.hs0000644000000000000000000000660012226700613014213 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} -------------------------------------------------------------------------------- -- | -- Module : Numeric.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable ------------------------------------------------------------------------------- module Numeric.Lens ( base , integral -- * Predefined bases , binary , octal , decimal , hex ) where import Control.Lens import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit) import Data.Maybe (fromMaybe) import Numeric (readInt, showIntAtBase) -- $setup -- >>> :set -XNoOverloadedStrings -- | This 'Prism' extracts can be used to model the fact that every 'Integral' -- type is a subset of 'Integer'. -- -- Embedding through the 'Prism' only succeeds if the 'Integer' would pass -- through unmodified when re-extracted. integral :: (Integral a, Integral b) => Prism Integer Integer a b integral = prism toInteger $ \ i -> let a = fromInteger i in if toInteger a == i then Right a else Left i -- | A prism that shows and reads integers in base-2 through base-36 -- -- >>> "100" ^? base 16 -- Just 256 -- -- >>> 1767707668033969 ^. re (base 36) -- "helloworld" base :: Integral a => Int -> Prism' String a base b | b < 2 || b > 36 = error ("base: Invalid base " ++ show b) | otherwise = prism intShow intRead where intShow n = showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) "" intRead s = case readSigned' (readInt (fromIntegral b) (isDigit' b) digitToInt') s of [(n,"")] -> Right n _ -> Left s {-# INLINE base #-} -- | Like 'Data.Char.intToDigit', but handles up to base-36 intToDigit' :: Int -> Char intToDigit' i | i >= 0 && i < 10 = chr (ord '0' + i) | i >= 10 && i < 36 = chr (ord 'a' + i - 10) | otherwise = error ("intToDigit': Invalid int " ++ show i) -- | Like 'Data.Char.digitToInt', but handles up to base-36 digitToInt' :: Char -> Int digitToInt' c = fromMaybe (error ("digitToInt': Invalid digit " ++ show c)) (digitToIntMay c) -- | A safe variant of 'digitToInt'' digitToIntMay :: Char -> Maybe Int digitToIntMay c | isDigit c = Just (ord c - ord '0') | isAsciiLower c = Just (ord c - ord 'a' + 10) | isAsciiUpper c = Just (ord c - ord 'A' + 10) | otherwise = Nothing -- | Select digits that fall into the given base isDigit' :: Int -> Char -> Bool isDigit' b c = case digitToIntMay c of Just i -> i < b _ -> False -- | A simpler variant of 'Numeric.showSigned' that only prepends a dash and -- doesn't know about parentheses showSigned' :: Real a => (a -> ShowS) -> a -> ShowS showSigned' f n | n < 0 = showChar '-' . f (negate n) | otherwise = f n -- | A simpler variant of 'Numeric.readSigned' that supports any base, only -- recognizes an initial dash and doesn't know about parentheses readSigned' :: Real a => ReadS a -> ReadS a readSigned' f ('-':xs) = f xs & mapped . _1 %~ negate readSigned' f xs = f xs -- | @'binary' = 'base' 2@ binary :: Integral a => Prism' String a binary = base 2 -- | @'octal' = 'base' 8@ octal :: Integral a => Prism' String a octal = base 8 -- | @'decimal' = 'base' 10@ decimal :: Integral a => Prism' String a decimal = base 10 -- | @'hex' = 'base' 16@ hex :: Integral a => Prism' String a hex = base 16 lens-3.10/src/System/0000755000000000000000000000000012226700613012636 5ustar0000000000000000lens-3.10/src/System/Exit/0000755000000000000000000000000012226700613013547 5ustar0000000000000000lens-3.10/src/System/Exit/Lens.hs0000644000000000000000000000431612226700613015010 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : System.Exit.Lens -- Copyright : (C) 2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Control.Exception -- -- These prisms can be used with the combinators in "Control.Exception.Lens". ---------------------------------------------------------------------------- module System.Exit.Lens ( AsExitCode(..) , _ExitFailure , _ExitSuccess ) where import Control.Applicative import Control.Exception import Control.Exception.Lens import Control.Lens import System.Exit -- | Exit codes that a program can return with: class AsExitCode p f t where -- | -- @ -- '_ExitCode' :: 'Equality'' 'ExitCode' 'ExitCode' -- '_ExitCode' :: 'Prism'' 'SomeException' 'ExitCode' -- @ _ExitCode :: Overloaded' p f t ExitCode instance AsExitCode p f ExitCode where _ExitCode = id {-# INLINE _ExitCode #-} instance (Choice p, Applicative f) => AsExitCode p f SomeException where _ExitCode = exception {-# INLINE _ExitCode #-} -- | indicates successful termination; -- -- @ -- '_ExitSuccess' :: 'Prism'' 'ExitCode' () -- '_ExitSuccess' :: 'Prism'' 'SomeException' () -- @ _ExitSuccess :: (AsExitCode p f t, Choice p, Applicative f) => Overloaded' p f t () _ExitSuccess = _ExitCode . dimap seta (either id id) . right' . rmap (ExitSuccess <$) where seta ExitSuccess = Right () seta t = Left (pure t) {-# INLINE _ExitSuccess #-} -- | indicates program failure with an exit code. The exact interpretation of the code is operating-system dependent. In particular, some values may be prohibited (e.g. 0 on a POSIX-compliant system). -- -- @ -- '_ExitFailure' :: 'Prism'' 'ExitCode' 'Int' -- '_ExitFailure' :: 'Prism'' 'SomeException' 'Int' -- @ _ExitFailure :: (AsExitCode p f t, Choice p, Applicative f) => Overloaded' 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) {-# INLINE _ExitFailure #-} lens-3.10/src/System/FilePath/0000755000000000000000000000000012226700613014332 5ustar0000000000000000lens-3.10/src/System/FilePath/Lens.hs0000644000000000000000000001313212226700613015567 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.FilePath.Lens -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module System.FilePath.Lens ( -- * Operators (~), (<~), (<.>~), (<<.>~) , (=), (<=), (<.>=), (<<.>=) -- * Lenses , basename, directory, extension, filename ) where import Control.Applicative ((<$>)) import Control.Monad.State as State import System.FilePath ( (), (<.>), splitExtension , takeBaseName, takeDirectory , takeExtension, takeFileName ) import Control.Lens hiding ((<.>)) -- $setup -- >>> :set -XNoOverloadedStrings infixr 4 ~, <~, <.>~, <<.>~ infix 4 =, <=, <.>=, <<.>= -- | Modify the path by adding another path. -- -- >>> both ~ "bin" $ ("hello","world") -- ("hello/bin","world/bin") -- -- @ -- ('~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- ('~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- ('~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- ('~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- @ (~) :: ASetter s t FilePath FilePath -> FilePath -> s -> t l ~ n = over l ( n) {-# INLINE (~) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding a path. -- -- >>> execState (both = "bin") ("hello","world") -- ("hello/bin","world/bin") -- -- @ -- ('=') :: 'MonadState' s m => 'Setter'' s 'FilePath' -> 'FilePath' -> m () -- ('=') :: 'MonadState' s m => 'Iso'' s 'FilePath' -> 'FilePath' -> m () -- ('=') :: 'MonadState' s m => 'Lens'' s 'FilePath' -> 'FilePath' -> m () -- ('=') :: 'MonadState' s m => 'Traversal'' s 'FilePath' -> 'FilePath' -> m () -- @ (=) :: MonadState s m => ASetter' s FilePath -> FilePath -> m () l = b = State.modify (l ~ b) {-# INLINE (=) #-} -- | Add a path onto the end of the target of a 'Lens' and return the result -- -- When you do not need the result of the operation, ('~') is more flexible. (<~) :: LensLike ((,)FilePath) s a FilePath FilePath -> FilePath -> s -> (FilePath, a) l <~ m = l <%~ ( m) {-# INLINE (<~) #-} -- | Add a path onto the end of the target of a 'Lens' into -- your monad's state and return the result. -- -- When you do not need the result of the operation, ('=') is more flexible. (<=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> FilePath -> m FilePath l <= r = l <%= ( r) {-# INLINE (<=) #-} -- | Modify the path by adding extension. -- -- >>> both <.>~ "txt" $ ("hello","world") -- ("hello.txt","world.txt") -- -- @ -- ('<.>~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- ('<.>~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- ('<.>~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- ('<.>~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- @ (<.>~) :: ASetter s a FilePath FilePath -> String -> s -> a l <.>~ n = over l (<.> n) {-# INLINE (<.>~) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding an extension. -- -- >>> execState (both <.>= "txt") ("hello","world") -- ("hello.txt","world.txt") -- -- @ -- ('<.>=') :: 'MonadState' s m => 'Setter'' s 'FilePath' -> 'String' -> m () -- ('<.>=') :: 'MonadState' s m => 'Iso'' s 'FilePath' -> 'String' -> m () -- ('<.>=') :: 'MonadState' s m => 'Lens'' s 'FilePath' -> 'String' -> m () -- ('<.>=') :: 'MonadState' s m => 'Traversal'' s 'FilePath' -> 'String' -> m () -- @ (<.>=) :: MonadState s m => ASetter' s FilePath -> String -> m () l <.>= b = State.modify (l <.>~ b) {-# INLINE (<.>=) #-} -- | Add an extension onto the end of the target of a 'Lens' and return the result -- -- >>> _1 <<.>~ "txt" $ ("hello","world") -- ("hello.txt",("hello.txt","world")) -- -- When you do not need the result of the operation, ('<.>~') is more flexible. (<<.>~) :: LensLike ((,)FilePath) s a FilePath FilePath -> String -> s -> (FilePath, a) l <<.>~ m = l <%~ (<.> m) {-# INLINE (<<.>~) #-} -- | 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") -- "hello.txt" -- -- When you do not need the result of the operation, ('<.>=') is more flexible. (<<.>=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> String -> m FilePath l <<.>= r = l <%= (<.> r) {-# INLINE (<<.>=) #-} -- | A 'Lens' for reading and writing to the basename -- -- >>> basename .~ "filename" $ "path/name.png" -- "path/filename.png" basename :: Lens' FilePath FilePath basename f p = (<.> takeExtension p) . (takeDirectory p ) <$> f (takeBaseName p) {-# INLINE basename #-} -- | A 'Lens' for reading and writing to the directory -- -- >>> "long/path/name.txt" ^. directory -- "long/path" directory :: Lens' FilePath FilePath directory f p = ( takeFileName p) <$> f (takeDirectory p) {-# INLINE directory #-} -- | A 'Lens' for reading and writing to the extension -- -- >>> extension .~ ".png" $ "path/name.txt" -- "path/name.png" extension :: Lens' FilePath FilePath extension f p = (n <.>) <$> f e where (n, e) = splitExtension p {-# INLINE extension #-} -- | A 'Lens' for reading and writing to the full filename -- -- >>> filename .~ "name.txt" $ "path/name.png" -- "path/name.txt" filename :: Lens' FilePath FilePath filename f p = (takeDirectory p ) <$> f (takeFileName p) {-# INLINE filename #-} lens-3.10/src/System/IO/0000755000000000000000000000000012226700613013145 5ustar0000000000000000lens-3.10/src/System/IO/Error/0000755000000000000000000000000012226700613014236 5ustar0000000000000000lens-3.10/src/System/IO/Error/Lens.hs0000644000000000000000000000613312226700613015476 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : System.IO.Error.Lens -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module System.IO.Error.Lens where import Control.Lens import Control.Exception.Lens import GHC.IO.Exception import System.IO import Foreign.C.Types -- * 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 } {-# 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 } {-# 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 } {-# 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 } {-# 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 } {-# INLINE errno #-} ------------------------------------------------------------------------------ -- Error Types ------------------------------------------------------------------------------ -- | 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 } {-# INLINE errorType #-} -- * IOErrorType Prisms -- -- (These prisms are generated automatically) makePrisms ''IOErrorType lens-3.10/tests/0000755000000000000000000000000012226700613011725 5ustar0000000000000000lens-3.10/tests/doctests.hsc0000644000000000000000000000450112226700613014254 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (deps) import Control.Applicative import Control.Monad import Data.List import System.Directory import System.FilePath import Test.DocTest ##if defined(mingw32_HOST_OS) ##if defined(i386_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt ##elif defined(x86_64_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt ##endif ##endif -- | Run in a modified codepage where we can print UTF-8 values on Windows. withUnicode :: IO a -> IO a ##ifdef USE_CP withUnicode m = do cp <- c_GetConsoleCP (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp ##else withUnicode m = m ##endif main :: IO () main = withUnicode $ getSources >>= \sources -> doctest $ "-isrc" : "-idist/build/autogen" : "-optP-include" : "-optPdist/build/autogen/cabal_macros.h" : "-hide-all-packages" : map ("-package="++) deps ++ sources getSources :: IO [FilePath] getSources = filter (isSuffixOf ".hs") <$> go "src" where go dir = do (dirs, files) <- getFilesAndDirectories dir (files ++) . concat <$> mapM go dirs getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c lens-3.10/tests/hunit.hs0000644000000000000000000002215212226700613013412 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Main (hunit) -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides a simple hunit test suite for lens. -- -- The code attempts to enumerate common use cases rather than give an example -- of each available lens function. The tests here merely scratch the surface -- of what is possible using the lens package; there are a great many use cases -- (and lens functions) that aren't covered. ----------------------------------------------------------------------------- module Main where import Control.Lens import Control.Monad.State import Data.Char import Data.List as List import Data.Monoid import Data.Map as Map import Test.Framework.Providers.HUnit import Test.Framework.TH import Test.Framework import Test.HUnit hiding (test) data Point = Point { _x :: Int -- ^ X coordinate , _y :: Int -- ^ Y coordinate } deriving (Show, Eq, Ord) makeLenses ''Point data Box = Box { _low :: Point -- ^ The lowest used coordinates. , _high :: Point -- ^ The highest used coordinates. } deriving (Show, Eq) makeLenses ''Box data Polygon = Polygon { _points :: [ Point ] , _labels :: Map Point String , _box :: Box } deriving (Show, Eq) makeLenses ''Polygon data Shape = SBox Box | SPolygon Polygon | SCircle Point Int | SVoid makePrisms ''Shape origin = Point { _x = 0, _y = 0 } vectorFrom fromPoint toPoint = Point { _x = toPoint^.x - fromPoint^.x , _y = toPoint^.y - fromPoint^.y } trig = Polygon { _points = [ Point { _x = 0, _y = 0 } , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] , _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin") , (Point { _x = 4, _y = 7 }, "Peak") ] , _box = Box { _low = Point { _x = 0, _y = 0 } , _high = Point { _x = 8, _y = 7 } } } case_read_record_field = (trig^.box.high.y) @?= 7 case_read_state_record_field = runState test trig @?= (7, trig) where test = use $ box.high.y case_read_record_field_and_apply_function = (trig^.points.to last.to (vectorFrom origin).x) @?= 8 case_read_state_record_field_and_apply_function = runState test trig @?= (8, trig) where test = use $ points.to last.to (vectorFrom origin).x case_write_record_field = (trig & box.high.y .~ 6) @?= trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = 6 } } } case_write_state_record_field = do let trig' = trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = 6 } } } runState test trig @?= ((), trig') where test = box.high.y .= 6 case_write_record_field_and_access_new_value = (trig & box.high.y <.~ 6) @?= (6, trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = 6 } } }) case_write_state_record_field_and_access_new_value = do let trig' = trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = 6 } } } runState test trig @?= (6, trig') where test = box.high.y <.= 6 case_write_record_field_and_access_old_value = (trig & box.high.y <<.~ 6) @?= (7, trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = 6 } } }) case_write_state_record_field_and_access_old_value = do let trig' = trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = 6 } } } runState test trig @?= (7, trig') where test = box.high.y <<.= 6 case_modify_record_field = (trig & box.low.y %~ (+ 2)) @?= trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 2) } } } case_modify_state_record_field = do let trig' = trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 2) } } } runState test trig @?= ((), trig') where test = box.low.y %= (+ 2) case_modify_record_field_and_access_new_value = (trig & box.low.y <%~ (+ 2)) @?= (2, trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 2) } } }) case_modify_state_record_field_and_access_new_value = do let trig' = trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 2) } } } runState test trig @?= (2, trig') where test = box.low.y <%= (+ 2) case_modify_record_field_and_access_old_value = (trig & box.low.y <<%~ (+ 2)) @?= (0, trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 2) } } }) case_modify_state_record_field_and_access_old_value = do let trig' = trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 2) } } } runState test trig @?= (0, trig') where test = box.low.y <<%= (+ 2) case_modify_record_field_and_access_side_result = do runState test trig @?= (8, trig') where test = box.high %%= modifyAndCompute modifyAndCompute point = (point ^. x, point & y +~ 2) trig' = trig { _box = (trig & _box) { _high = (trig & _box & _high) { _y = ((trig & _box & _high & _y) + 2) } } } case_increment_record_field = (trig & box.low.y +~ 1) -- And similarly for -~ *~ //~ ^~ ^^~ **~ ||~ &&~ @?= trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 1) } } } case_increment_state_record_field = runState test trig @?= ((), trig') where test = box.low.y += 1 trig' = trig { _box = (trig & _box) { _low = (trig & _box & _low) { _y = ((trig & _box & _low & _y) + 1) } } } case_append_to_record_field = (trig & points <>~ [ origin ]) @?= trig { _points = (trig & _points) <> [ origin ] } case_append_to_state_record_field = do runState test trig @?= ((), trig') where test = points <>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } case_append_to_record_field_and_access_new_value = (trig & points <<>~ [ origin ]) @?= (_points trig <> [ origin ], trig { _points = (trig & _points) <> [ origin ] }) case_append_to_state_record_field_and_access_new_value = do runState test trig @?= (_points trig <> [ origin ], trig') where test = points <<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } case_append_to_record_field_and_access_old_value = (trig & points <<%~ (<>[origin])) @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] }) case_append_to_state_record_field_and_access_old_value = do runState test trig @?= (_points trig, trig') where test = points <<%= (<>[origin]) trig' = trig { _points = (trig & _points) <> [ origin ] } case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin" case_read_maybe_state_map_entry = runState test trig @?= (Just "Origin", trig) where test = use $ labels.at origin case_read_map_entry = trig^.labels.ix origin @?= "Origin" case_read_state_map_entry = runState test trig @?= ("Origin", trig) where test = use $ labels.ix origin case_modify_map_entry = (trig & labels.ix origin %~ List.map toUpper) @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN") , (Point { _x = 4, _y = 7 }, "Peak") ] } case_insert_maybe_map_entry = (trig & labels.at (Point { _x = 8, _y = 0 }) .~ Just "Right") @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin") , (Point { _x = 4, _y = 7 }, "Peak") , (Point { _x = 8, _y = 0 }, "Right") ] } case_delete_maybe_map_entry = (trig & labels.at origin .~ Nothing) @?= trig { _labels = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } case_read_list_entry = (trig ^? points.element 0) @?= Just origin case_write_list_entry = (trig & points.element 0 .~ Point { _x = 2, _y = 0 }) @?= trig { _points = [ Point { _x = 2, _y = 0 } , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] } case_write_through_list_entry = (trig & points.element 0 . x .~ 2) @?= trig { _points = [ Point { _x = 2, _y = 0 } , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] } main :: IO () main = defaultMain [$testGroupGenerator] lens-3.10/tests/properties.hs0000644000000000000000000001751112226700613014462 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main (properties) -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module provides a set of QuickCheck properties that can be run through -- test-framework to validate a number of expected behaviors of the library. ----------------------------------------------------------------------------- module Main where import Control.Applicative import Control.Lens import Test.QuickCheck import Test.QuickCheck.Function import Test.Framework.TH import Test.Framework.Providers.QuickCheck2 import Data.Char (isAlphaNum, isAscii, toUpper) import Data.Text.Strict.Lens import Data.Maybe import Data.List.Lens 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 -- an illegal lens bad :: Lens' (Int,Int) Int bad f (a,b) = (,) b <$> f a badIso :: Iso' Int Bool badIso = iso even fromEnum -- Control.Lens.Type prop_1 = isLens (_1 :: Lens' (Int,Double,()) Int) prop_2 = isLens (_2 :: Lens' (Int,Bool) Bool) prop_3 = isLens (_3 :: Lens' (Int,Bool,()) ()) prop_4 = isLens (_4 :: Lens' (Int,Bool,(),Maybe Int) (Maybe Int)) prop_5 = isLens (_5 :: Lens' ((),(),(),(),Int) Int) prop_2_2 = isLens (_2._2 :: Lens' (Int,(Int,Bool),Double) Bool) -- prop_illegal_lens = expectFailure $ isLens bad -- prop_illegal_traversal = expectFailure $ isTraversal bad -- prop_illegal_setter = expectFailure $ isSetter bad -- prop_illegal_iso = expectFailure $ isIso badIso -- Control.Lens.Setter prop_mapped = isSetter (mapped :: Setter' [Int] Int) 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) prop_simple = isIso (simple :: Iso' Int Int) --prop_enum = isIso (enum :: Iso' Int Char) prop__Left = isPrism (_Left :: Prism' (Either Int Bool) Int) prop__Right = isPrism (_Right :: Prism' (Either Int Bool) Bool) prop__Just = isPrism (_Just :: Prism' (Maybe Int) Int) -- Data.List.Lens prop_strippingPrefix s = isPrism (strippingPrefix s :: Prism' String String) -- Data.Text.Lens prop_text s = s^.packed.from packed == s --prop_text = isIso packed -- Numeric.Lens prop_base_show (n :: Integer) = conjoin [ show n == n ^. re (base 10) , showSigned showOct 0 n "" == n ^. re (base 8) , showSigned showHex 0 n "" == n ^. re (base 16) ] prop_base_read (n :: Integer) = conjoin [ show n ^? base 10 == Just n , showSigned showOct 0 n "" ^? base 8 == Just n , showSigned showHex 0 n "" ^? base 16 == Just n , map toUpper (showSigned showHex 0 n "") ^? base 16 == Just n ] prop_base_readFail (s :: String) = forAll (choose (2,36)) $ \b -> not isValid ==> s ^? base b == Nothing where 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 lens-3.10/tests/templates.hs0000644000000000000000000000702712226700613014265 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Main (templates) -- Copyright : (C) 2012-13 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- 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 ----------------------------------------------------------------------------- module Main where import Control.Lens -- import Test.QuickCheck (quickCheck) 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') data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } makeLenses ''Quux -- quaffle :: Lens (Quux a b) (Quux a' b') Int Int -- quartz :: Lens (Quux a b) (Quux a' b') Double Double data Quark a = Qualified { _gaffer :: a } | Unqualified { _gaffer :: a, _tape :: a } makeLenses ''Quark -- gaffer :: Simple Lens (Quark a) a -- tape :: Simple Traversal (Quark a) a data Hadron a b = Science { _a1 :: a, _a2 :: a, _b :: 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' data Perambulation a b = Mountains { _terrain :: a, _altitude :: b } | Beaches { _terrain :: a, _dunes :: a } makeLenses ''Perambulation -- terrain :: Simple Lens (Perambulation a b) a -- altitude :: Traversal (Perambulation a b) (Parambulation a b') b b' -- dunes :: Simple Traversal (Perambulation a b) a makeLensesFor [("_terrain", "allTerrain"), ("_dunes", "allTerrain")] ''Perambulation -- allTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a' data LensCrafted a = Still { _still :: a } | Works { _still :: a } makeLenses ''LensCrafted -- still :: Lens (LensCrafted a) (LensCrafted b) a b data Danger a = Zone { _highway :: a } | Twilight makeLensesWith (partialLenses .~ True $ buildTraversals .~ False $ lensRules) ''Danger -- highway :: Lens (Danger a) (Danger a') a a' data Task a = Task { taskOutput :: a -> IO () , taskState :: a , taskStop :: IO () } makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task data Mono a = Mono { _monoFoo :: a, _monoBar :: Int } makeClassy ''Mono -- class HasMono t where -- mono :: Simple Lens t Mono -- instance HasMono Mono where -- mono = id -- monoFoo :: HasMono t => Simple Lens t Int -- monoBar :: HasMono t => Simple Lens t Int data Nucleosis = Nucleosis { _nuclear :: Mono Int } makeClassy ''Nucleosis -- class HasNucleosis t where -- nucleosis :: Simple Lens t Nucleosis -- instance HasNucleosis Nucleosis -- nuclear :: HasNucleosis t => Simple Lens t Mono instance HasMono Nucleosis Int where mono = nuclear -- Dodek's example data Foo = Foo { _fooX, _fooY :: Int } makeClassy ''Foo data Dude a = Dude { _dudeLevel :: Int , _dudeAlias :: String , _dudeLife :: () , _dudeThing :: a } data Lebowski a = Lebowski { _lebowskiAlias :: String , _lebowskiLife :: Int , _lebowskiMansion :: String , _lebowskiThing :: Maybe a } makeFields ''Dude makeFields ''Lebowski main :: IO () main = putStrLn "test/templates.hs: ok" lens-3.10/travis/0000755000000000000000000000000012226700613012073 5ustar0000000000000000lens-3.10/travis/cabal-apt-install0000755000000000000000000000127212226700613015313 0ustar0000000000000000#! /bin/bash set -eu APT="sudo apt-get -q -y" CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" $APT update $APT install dctrl-tools # Find potential system packages to satisfy cabal dependencies deps() { local M='^\([^ ]\+\)-[0-9.]\+ (.*$' local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ | sed -ne "s/$M/$G/p" | sort -u)" grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u } $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 lens-3.10/travis/config0000644000000000000000000000120612226700613013262 0ustar0000000000000000-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global