lens-5.2.3/0000755000000000000000000000000007346545000010653 5ustar0000000000000000lens-5.2.3/.gitignore0000644000000000000000000000030007346545000012634 0ustar0000000000000000dist/ dist-newstyle/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# cabal.project.local .cabal-sandbox/ cabal.sandbox.config .stack-work/ codex.tags .ghc.environment.* lens-5.2.3/.hlint.yaml0000644000000000000000000000225207346545000012734 0ustar0000000000000000- arguments: [-XCPP, --cpp-ansi, --cpp-include=include] - ignore: {name: Reduce duplication} - ignore: {name: Redundant lambda} - ignore: {name: Use >=>} - ignore: {name: Use const} - ignore: {name: Use module export list} - ignore: {name: Use lambda-case} - ignore: {name: Use tuple-section} - ignore: {name: Use fewer imports} - ignore: {name: "Use :"} - ignore: {name: Use typeRep, within: [Control.Lens.Internal.Typeable, Control.Lens.Internal.Exception]} - ignore: {name: Eta reduce, within: [Control.Lens.At, Control.Lens.Zoom, Control.Lens.Equality, Control.Lens.Traversal]} # Breaks code - ignore: {name: Use id, within: [Control.Lens.Equality]} - ignore: {name: Use camelCase, within: [Control.Lens.Internal.TH]} - ignore: {name: Use list comprehension, within: [Control.Lens.Internal.FieldTH]} - ignore: {name: Use fmap, within: [Control.Exception.Lens, Control.Lens.Internal.Zoom, Control.Lens.Zoom, Control.Lens.Indexed, Control.Lens.Fold, Control.Monad.Error.Lens,Control.Lens.Setter]} # Needed to support pre-AMP GHC-7.8 - ignore: {name: Use uncurry} - ignore: {name: Fuse concatMap/<&>, within: [Control.Lens.Internal.FieldTH]} - fixity: "infixr 9 ..." - fixity: "infixl 1 &~" lens-5.2.3/.vim.custom0000644000000000000000000000141407346545000012760 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;/,codex.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-5.2.3/AUTHORS.markdown0000644000000000000000000000640107346545000013545 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) * [Niklas Haas](mailto:niklas.haas@uni-ulm.de) [@nandykins](https://github.com/nandykins) * [Adrian Keet](mailto:arkeet@gmail.com) [@arkeet](https://github.com/arkeet) * [Matvey B. Aksenov](mailto:matvey.aksenov@gmail.com) [@supki](https://github.com/supki) * [Eyal Lotem](mailto:eyal.lotem+github@gmail.com) [@Peaker](https://github.com/Peaker) * [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) * [Bradford Larsen](mailto:brad.larsen@gmail.com) [@bradlarsen](https://github.com/bradlarsen) * [Alex Mason](mailto:axman6@gmail.com) [@Axman6](https://github.com/Axman6) * [Ryan Scott](mailto:ryan.gl.scott@gmail.com) [@RyanGlScott](https://github.com/RyanGlScott) 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-5.2.3/CHANGELOG.markdown0000644000000000000000000017066507346545000013725 0ustar00000000000000005.2.3 [2023.08.24] ------------------ * Allow building with GHC 9.8. * Add new `Prism`s to `Language.Haskell.TH.Lens` to reflect recent additions to `template-haskell`: * `_GetFieldE` and `_ProjectionE` `Prism`s for the `Exp` data type, whose corresponding data constructors were introduced in `template-haskell-2.18.*`. * `_TypedBracketE` and `_TypedSpliceE` `Prism`s for the `Exp` data type, whose corresponding data constructors were introduced in `template-haskell-2.21.*`. * `_BndrReq` and `_BndrInvis` `Prism`s for the `BndrVis` data type, which was added in `template-haskell-2.21.*`. * Add a `generateRecordSyntax` option to `Control.Lens.TH`, which controls whether to generate lenses using record update syntax or not. By default, this option is disabled. * Fix a bug in which the `declare*` Template Haskell functions would fail if a data type's field has a type that is defined in the same Template Haskell quotation. * Add `altOf`, which collects targets into any `Alternative`. 5.2.2 [2023.03.18] ------------------ * Fix a bug in which calling `ix i` (where `i` is a negative number) on `Text` or `ByteString` would return the `Just` the first character instead of returning `Nothing`. 5.2.1 [2023.02.27] ------------------ * Allow building with GHC 9.6. * Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, such as the WASM backend. * Support building with `th-abstraction-0.5.*`. * Define `_TypeDataD` in `Language.Haskell.TH.Lens` when building with `template-haskell-2.20.0.0` (GHC 9.6) or later. 5.2 [2022.08.11] ---------------- * Allow building with GHC 9.4. * The type of `universeOf` has changed: ```diff -universeOf :: Getting [a] a a -> a -> [a] +universeOf :: Getting (Endo [a]) a a -> a -> [a] ``` In many cases, using `Endo [a]` over `[a]` improves performance. Most call sites to `universeOf` will not be affected by this change, although you may need to update your code if you define your own combinators in terms of `universeOf`. * Allow `makeWrapped` to accept the names of data constructors. This way, `makeWrapped` can be used with data family instances, much like other functions in `Control.Lens.TH`. * Define `_OpaqueP`, `_DefaultD`, `_LamCasesE`, `_PromotedInfixT`, and `_PromotedUInfixT` in `Language.Haskell.TH.Lens` when building with `template-haskell-2.19.0.0` (GHC 9.4) or later. 5.1.1 [2022.05.17] ------------------ * Add `Data.HashSet.Lens.hashMap`, an `Iso` between a `HashSet a` and a `HashMap a ()`. * Allow building with `transformers-0.6.*` and `mtl-2.3.*`. Note that `lens` no longer defines `Zoom` instances for `ErrorT` or `ListT` when building with `mtl-2.3` or later. This is because `MonadState` is a superclass of `Zoom`, and the `MonadState` instances for `ErrorT` and `ListT` were removed in `mtl-2.3`. Be watchful of this if you build `lens` with `mtl-2.3` (or later) combined with an older version of `transformers` (pre-`0.6`) that defines `ErrorT` or `ListT`. 5.1 [2021.11.15] ---------------- * Allow building with GHC 9.2. * Drop support for GHC 7.10 and older. * The type of `_ConP` in `Language.Haskell.TH.Lens` is now `Prism' Pat (Name, [Type], [Pat])` instead of `Prism' Pat (Name, [Pat])` when building with `template-haskell-2.18` or later. * Define `_CharTyLit` in `Language.Haskell.TH.Lens` when building with `template-haskell-2.18` or later. * Add `Prefixed` and `Suffixed` classes to `Control.Lens.Prism`, which provide `prefixed` and `suffixed` prisms for prefixes and suffixes of sequence types. These classes generalize the `prefixed` and `suffixed` functions in `Data.List.Lens`, which were previously top-level functions. In addition to providing `Prefixed` and `Suffixed` instances for lists, instances for `Text` and `ByteString` types are also provided. At present, `Prefixed` and `Suffixed` are re-exported from `Data.List.Lens` for backwards compatibility. This may change in a future version of `lens`, however. * Add a `traversal` function to `Control.Lens.Traversal`. This function, aside from acting as a `Traversal` counterpart to the `lens` and `prism` functions, provides documentation on how to define `Traversal`s. * Add a `matching'` function to `Control.Lens.Prism`. `matching'` is like `matching`, but with a slightly more general type signature that allows it to work with combinations of `Lens`es, `Prism`s, and `Traversal`s. 5.0.1 [2021.02.24] ------------------ * Fix a bug in which `makeLenses` could produce ill kinded optics for poly-kinded datatypes in certain situations. 5 [2021.02.17] -------------- * Support building with GHC 9.0. * Remove the `Swapped` type class in favor of `Swap` from the `assoc` package. * Remove the `Strict` type class in favor of `Strict` from the `strict` package. The `swapped`, `strict` and `lazy` isomorphisms are now defined using "new" type classes. Users which define own instances of old type classes are advised to define instances of the new ones. ```haskell import qualified Data.Bifunctor.Swap as Swap import qualified Control.Lens as Lens instance Swap.Swap MyType where swap = ... #if !MIN_VERSION_lens(4,20,0) instance Lens.Swapped MyType where swapped = iso Swap.swap Swap.swap #endif ``` * The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type classes have been migrated to a new package, [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable). The `imapped`, `ifolded` and `itraversed` methods are now top-level functions. If you are not defining these methods in your instances, you don't need to change your definitions. Beware: the `optics-core` package (versions <0.4) defines similar classes, and will also migrate to use `indexed-traversable` classes. Therefore, you might get duplicate instance errors if your package defines both. If you define your own `FunctorWithIndex` etc. instances, we recommend that you depend directly on the `indexed-traversable` package. If you want to continue support `lens-4` users, you may write ```haskell -- from indexed-traversable import Data.Functor.WithIndex -- from lens import qualified Control.Lens as L -- your (indexed) container data MySeq a = ... -- indexed-traversable instance instance FunctorWithIndex Int MySeq where imap = ... instance FoldableWithIndex Int MySeq where ifoldMap = ... instance TraversableWithIndex Int MySeq where itraverse = ... -- lens <5 instance, note the ! #if !MIN_VERSION_lens(5,0,0) instance L.FunctorWithIndex Int MySeq where imap = imap instance L.FoldableWithIndex Int MySeq where ifoldMap = ifoldMap instance L.TraversableWithIndex Int MySeq where itraverse = itraverse #endif ``` In other words, always provide `indexed-traversable` instances. If your package depends on `lens` and allows `lens-4`, you should additionally provide instances for `lens-4` type classes that can reuse the `indexed-traversable` instances. * Make the functions in `Control.Lens.TH` work more robustly with poly-kinded data types. This can cause a breaking change under certain situations: * TH-generated optics for poly-kinded data types are now much more likely to mention kind variables in their definitions, which will require enabling the `PolyKinds` extension at use sites in order to typecheck. * Because TH-generated optics now quantify more kind variables than they did previously, this can affect the order of visible type applications. * Generalize the types of `generic` and `generic1` to allow type-changing updates. If you wish to use the old, more restricted types of these functions, use `simple . generic` or `simple . generic1` instead. * Add `Control.Lens.Profunctor` with conversion functions to and from profunctor optic representation. * Add `Control.Lens.Review.reviewing`, which is like `review` but with a more polymorphic type. * Mark `Control.Lens.Equality` as Trustworthy. * The build-type has been changed from `Custom` to `Simple`. To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. * Use `alterF` in `At (HashMap k)` instance implementation. * Use `alterF` in `At` and `Contains` instances for `Set`, `IntSet`, and `HashSet`. * Avoid re-inserting keys already present in `ix` for `Set`, `IntSet`, and `HashSet`. For `Set` and `HashSet`, this changes the semantics slightly; if the user-supplied key is `==` to one already present in the set, then the latter will not be replaced in the result. * Consume `()` values lazily in `Control.Lens.At`. 4.19.2 [2020.04.15] ------------------- * Remove the test suite's dependency on `test-framework-th`. 4.19.1 [2020.02.13] ------------------- * Fix a bug introduced in 4.19 where using `_TupE` to `preview` a value would always fail. 4.19 [2020.02.03] ----------------- * Support building with GHC 8.10. * The types of `_TupE` and `_UnboxedTupE` are now `Prism' Exp [Maybe Exp]` when built against `template-haskell-2.16` or later to reflect the new types of `TupE` and `UnboxedTupE`. * Add `_ForallVisT` and `_BytesPrimL` prisms when building against `template-haskell-2.16` or later. * Make `<>~` and `<>=` and their `)` from `Data.Functor` on `base-4.11` and later. * Added `Cons` and `Snoc` instances for `Control.Applicative.ZipList` * Fix a bug in which `makeFields` would generate equality constraints for field types involving data families, which are unnecessary. * Improve the performance of `holesOf`. 4.16 [2018.01.28] ----------------- * The `Semigroup` instances for `Traversed` and `Sequenced` are now more constrained (going from `Apply` to `Applicative` and `Monad`, respectively). In GHC 8.4, `Semigroup` is a superclass of `Monoid`, therefore we'd need to have `Apply` constraint in the `Monoid` instances. We opted to weaken our ability to use `Apply` than to lose compatibility with third-party packages that don't supply instances for `Apply`. In practice this changes the (specialised) type signature of `traverseOf_` ```diff+ - traverseOf_ :: Apply f => Fold1 s a -> (a -> f r) -> s -> f () + traverseOf_ :: Applicative f => Fold1 s a -> (a -> f r) -> s -> f () ``` and similarly for `forOf_` and `sequenceOf_`. As part of this change, new combinators `traverse1Of_`, `for1Of_` and `sequence1Of_` were added for `Apply`-only effects. Similar instance context changes were made for `Folding` and `Effect`, but these changes aren't publicly visible. * Add `Control.Lens.Unsound`, which exports unsound functionality for forming products of lenses and sums of prisms. * Add `Numeric.Natural.Lens`, which export convenient isomorphisms for natural numbers. * Add `Strict` instances for strict and lazy `ST`. * Adapt `Language.Haskell.TH.Lens` for `template-haskell-2.13` (bundled with GHC 8.4). * Add `Semigroup` and `Monoid` instances for `Indexing`. 4.15.4 ---- * `makeFields` and `declareFields` are now smarter with respect to type families. Because GHC does not allow mentioning type families in instance heads, the Template Haskell machinery works around this restriction by instead generating instances of the form: ```haskell type family Fam a data Rec a = Rec { _recFam :: Fam a } makeFields ''Rec ===> instance (b ~ Fam a) => HasFam (Rec a) b where ... ``` This requires enabling the `UndecidableInstances` extension, so this trick is only employed when a field's type contains a type family application. * `declareFields` now avoids creating duplicate field classes that are shared among multiple datatypes within the same invocation. * The Template Haskell machinery will no longer generate optics for fields whose types mention existentially quantified type variables. * Add `HasCallStack` constraints to partial operations * Reexport `(.@~)` and `(.@=)` from `Control.Lens.Operators` * Support `doctest-0.13` 4.15.3 ---- * Generalized types of `transformMOf`, `transformOf`, `transformMOnOf`, `transformOnOf`, `rewriteMOf`, `rewriteOf`, `rewriteMOnOf` and `rewriteOnOf`. * Depend on `th-abstraction` package for normalizing differences across `template-haskell` versions 4.15.2 ---- * Build with GHC 8.2 * Expand tuple accessors to support up to 19-tuples * Add more `Rewrapped` and `Wrapped` instances for data types from the `base`, `bifunctors`, `exceptions`, `free`, `profunctors`, and `semigroupoids` libraries * Add a `Generic` default implementation for `Wrapped` * Add `Wrapped` instances for data types introduced in `Foreign.C.Types` and `System.Posix.Types` in `base-4.10.0.0` * Add prisms for recently introduced data types in `Control.Exception` * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and sandboxes. * Add `makeFieldsNoPrefix`, a variant of `makeFields` which gives the desired behavior in the presence of `DuplicateRecordFields`. Also add `classUnderscoreNoPrefixFields` and `classUnderscoreNoPrefixNamer`, the corresponding `LensRules` and `FieldNamer`, respectively. * Add `toNonEmptyOf`, `first1Of`, `last1Of`, `minimum1Of`, and `maximum1Of` to `Control.Lens.Fold` * Add `both1` to `Control.Lens.Traversal` * Generalize the type of `levels` and `ilevels` in `Control.Lens.Level` to work on `Fold`s * Generalize the type of `getting` in `Control.Lens.Getter` to work with any `Optical` * Add `throwing_` to `Control.Monad.Error.Lens` and `Control.Exception.Lens` * Fix the meta-data in the .cabal file to properly indicate that this project has a BSD2 license 4.15.1 ---- * Restore the `generic` and `generic1` functions in `GHC.Generics.Lens` 4.15 ---- * Remove `Generics.Deriving.Lens` module. * Incorporate `URec`, which was introduced in `GHC.Generics` in `base-4.9`. For compatibility with older versions of `base`, `lens` now conditionally depends on `generic-deriving` * Add `Rewrapped` instance for `ExceptT` * Add `FunctorWithIndex`, `FoldableWithIndex`, and `TraversableWithIndex` instances for `Sum`, `Proxy`, `Tagged` and data types in `GHC.Generics` * Remove unneeded context from `*WithIndex HashMap` instances * Add `Data.Map.Lens.toMapOf` * Add moral `Functor` constraint for `to` `ito` `ilike` `ilike` to allow the "indented" type signature using Getter with redundant warnings turned on. 4.14 ---- * Remove `Cons` and `Snoc` instances for `NonEmpty`. 4.13.2.1 ------ * Fixed `itraverse_` and `imapM_` returning bottom 4.13.2 ------ * Restore default signature for `Control.Lens.At.at` * Improve operations for `Data.Sequence.Seq` * Fix `declarePrisms` behavior on GHC 8 using GADT record syntax 4.13.1 ------ * Modified to enable the `doctests` to build with `stack`. * Removed `.ghci`. * Added `lookupOf` * Support GHC 8 * Support `transformers` 0.5 * Support `kan-extensions` 5 * Support `comonad` 5 * Better support for `Closed` from `profunctors`. 4.13 ---- * Pattern synonyms * Moved `foldMapBy` and `foldBy` into `reflection` 2.1 * Added `traverseByOf`, `sequenceByOf`. * Reexported `traverseBy` and `sequenceBy` from `reflection` 2.1. * Modified the signatures of `alaf` and `auf` to work with a `Functor` rather than a `Profunctor` and rather drastically generalized them. * Removed `Control.Lens.Internal.Getter.coerce` in favor of the upstream `phantom` combinator in `contravariant` 1.3+ * Renamed `coerced` to `phantasm` to get it out of the way. * Added `Wrapped` instance for `Down` 4.12.3 ------ * Move `Review` and `AReview` to `Control.Lens.Type` fixing a bug in `makePrisms` * Expose `HasTypes` class in `Language.Haskell.TH.Lens` * Make types of `foldByOf` and `foldMapByOf` more specific to hide implementation details * Add Prisms to `Language.Haskell.TH` for new constructors in `template-haskell-2.10` * Generalize type of `_FunDep` to an `Iso` 4.12.2 ------ * Incorporated a bug fix for `foldByOf` and `foldMapByOf` to actually let them work on folds. * Added a `Plated` instance for `CofreeT` 4.12.1 ------ * The `Simple` type alias is now poly-kinded. This lets you use `Simple Field1 s a` and the like in constraints. * Added `HasTypes` to `Language.Haskell.TH.Lens`. * Support for `vector-0.11.0` which changes `Stream` to `Bundle` 4.12 ---- * `reflection 2` support. 4.11.2 ------ * Give `cosmosOn` a more general type. 4.11.1 ------ * Added `cosmos`, `cosmosOf`, `cosmosOn`, `cosmosOnOf` to `Control.Lens.Plated`. * Added `icontains`, `iat`, `iix`. * Made various documentation improvements. * Added a `test-templates` flag. 4.11 ---- * Proper `profunctors` 5.1 support. This extended the superclass constraints for `Conjoined`, so it resulted in a major version bump. 4.10 ---- * Added `elemIndexOf`, `elemIndicesOf`, `findIndexOf`, and `findIndicesOf`. * Fixed `Ixed` instance for `Tree`. It no longer drops nodes prior to the traversed node. * `bifunctors` 5, `profunctors` 5 and `semigroupoids` 5 support. 4.9.1 ----- * Added `_Wrapped` support for `NonEmpty`. * Added `_Wrapped` support for `Alt`. * Fixed `Rewrapped` instance for `Last`. 4.9 ------- * `filepath` 1.4 support * Removed `Control.Monad.Primitive.Lens` and shed the `primitive` dependency. * Add missing `_WithIndex` instances from `keys` package * Much more code is inferred `Safe` rather than `Trustworthy`. * Documented the difference between `unsafeSingular` and `singular`. * `folding` now produces an actual `Fold`. * Cleaned up builds for GHC 7.10 to get rid of redundant import warnings. 4.8 --- * When built with `profunctors` 4.4 on GHC 7.8+ we no longer need to use `unsafeCoerce` at all! This drastically reduces the level of trust involved in the way we have optimized `lens`. * Added `fusing`. This optimizes long `Lens` chains, by enfocing a form of `fmap` fusion based on the Yoneda lemma. This is particularly effective at making faster lenses the definition is recursive or complex enough that it cannot be inlined. * Added `confusing`. This optimizes long `Traversal` chains. As with `fusing` it is best used when the definition for the `Traversal` chain in question is recursive or complex enough that it cannot be inlined, but the implementation is much more confusing. * Remove deprecated stuff: `Control.Lens.Loupe`, `headOf`, `makeFieldsWith`, `strippingPrefix`, `strippingSuffix` * Added `Cons` and `Snoc` instances for `NonEmpty` * Removed `Data.List.Split.Lens` module * Reimplemented `bytestring` traversals to avoid internal modules * Added `gplate`, an implementation of `plate` for any type implementing `Generic` * Strictness revisited * Add `generateLazyPatterns` configuration flag to `makeLenses` rules. * Make the default `makeLenses` behavior to generate STRICT optics * Add strict variants of `_1` .. `_9` named `_1'` .. `_9'` * Generalized some combinators in `Data.Vector.Generic.Lens` and added `converted` 4.7 --- * Migrated `Control.Lens.Action` to `lens-action`. * Added `Data.Vector.Generic.Lens.vectorIx` function for indexing vectors with only `Vector` constraint. * Added `Field1` and `Field2` instances for `Data.Functor.Product.Product`. * Removed the "typeclass synonym" `Gettable`. * Added new flag to `makeLenses`, `generateUpdateableOptics`, which allows the generation of only `Getter`s and `Fold`s. This feature is intended to be used when the constructors are hidden behind validating, "smart" constructors. * Fixed Template Haskell name generation when using GHC 7.10 * Fixed Template Haskell generation of classes methods where field types used existential quantification 4.6.0.1 [maintenance release] ------- * Compatibility with `base` 4.8 [Edit: this turned out to not work for the final release of GHC 7.10] 4.6 --- * Reduced `Review` to two arguments, like `Getter`. * Added `abbreviatedFields` to permit `makeFieldsWith` to be invoked with an argument that lets it act like it did pre-4.5 and accept arbitrary common prefixes. 4.5 --- * Provide access to the typename in `lensRules` naming function. * `makeFields` camelcasing rules now properly support types with camelcasing. `MyType` with field `myTypeFieldA` generates `fieldA` now. Previously the prefix ignore capitalization and the field would need to be named `mytypeFieldA`. * `makeClassy` works on types even when none of the fields would generate optics. * Added `Monad`, `MonadReader`, `MonadPlus` and `Bind` instances for `ReifiedMonadicFold` * Added missing fixity declarations on many operators. * Migrated `Codec.Compression.Zlib.Lens` to `zlib-lens` package. 4.4.0.2 --- * `text` 1.2.0.0 support * Remove the use of the TemplateHaskell extension from the library to enable lens to be used on stage1 cross-compilers 4.4.0.1 ---- * Restore previous default of `makeFields` using the camel case field namer. 4.4 ---- * Internals of Template Haskell code generation rewritten. makeLenses, makeClassy, and makeFields have been unified into the same generator. * TH generated single constructor Lens use irrefutable pattern matching to enable construction starting with undefined. * TH generated traverals unify their field arguments (type synonyms not currently expanded) enabling exotic traversals to be generated. * Added instances for `Text` to `Data.Aeson.Lens` * Reimplemented `makePrisms`, adding support for `makeClassyPrisms`, infix constructrs generate periods (.) prefixed prisms. * Added `Choice` to `Review` so that `Prism` is a proper subtype of `Review` * Migrated `Data.Aeson.Lens` to `lens-aeson` package. * Fixed `GHC.Generics.Lens.tinplate` behavior on single-field data types and empty data types. 4.3.3 ----- * `semigroupoids` 4.2 support 4.3.2 ----- * `contravariant` 1.0 support 4.3.1 ----- * Added `bytewise` to `Data.Bits` 4.3 --- * Switched the "direction" of the `Iso` argument to `au` to match the order generated by `makePrisms` and `makeLenses`. * Removed `makeIsos` in favor of `makePrisms` and `makeLenses`. Each of these functions will construct `Iso`s when appropriate. * Removed `declareIsos` in favor of `declarePrisms` and `declareLenses`. Each of these functions will construct `Iso`s when appropriate. * Added `matching` for type-changing matches with `Prism`s. * Added `withPrism` for recovering the functions passed to `prism`. * Added `negated`, the isomorphism for the `negate` function. 4.2 --- * Added `_Text` isomorphisms to make the proper use with `(#)` more obvious and fit newer convention. * Added `Wrapped` instances for `Vector` types * Resolved issue #439. The various `Prism`s for string-like types in `Data.Aeson.Lens` are now law-abiding `Prism`s "up to quotient." * Added `selfIndex`. * Support `attoparsec` 0.12. 4.1.2 ----- * When used with `exceptions` 0.4, `throwingM` will permit use with a mere `MonadThrow`. 4.1.1 ---- * Generalized the types of `mapping`, `bimapping`, `contramapping`, `dimapping`, `lmapping`, `rmapping` to support changing the `Functor`, `Bifunctor`, `Contravariant`, and `Profunctor` respectively. * Compatibility with `free` 4.6 4.1 --- * Added `Plated` instances for various free monad variants. * Compatibility with GHC HEAD (7.9+) 4.0.7 ----- * Removed dependency on `constraints`. It was used in a pre-release version of 4.0 but never made it into 4.0, but the dependency had remained around complicating builds for GHC 7.4. 4.0.6 ----- * `makeLenses` attempt to make the accessors it can under existential quantification. * Added `(&~)`. * _Experimental_ support for parallel builds on GHC 7.8 with `cabal install lens -fj`. Due to at last one known issue with GHC, it isn't recommended to use this option when rebuilding lens, as a race condition on at least one platform has been seen in the wild. * Added `RoleAnnotations` for GHC 7.8.1. These rule out a few user-accessible bottoms that could be caused by creative abuse of the new `Coercible` machinery. However, there was no `unsafeCoerce` exposed. * Removed some impossible cases that required unwritable instances from the example doctypes. 4.0.5 ----- * Added `bimapping` to `Control.Lens.Iso` * Restored correct behavior of `makePrism` on types with a single constructor. * `makeLenses` now generates `Getter`s and `Fold`s on universally quantified fields. 4.0.4 ----- * Made `declareFields` work again. 4.0.3 ----- * Fixed random segfaulting when using `foldMapBy`. 4.0.2 ----- * Properly bundled the modules needed for the properties test suite into the tarball for hackage. 4.0.1 ----- * Typo fixes * Exporting `Rewrapping` from `Control.Lens.Wrapped`. * Removed the dependency on `cpphs`. 4.0 ---- * Added `nearly` to `Control.Lens.Prism`. * Added `Control.Lens.Empty`, exporting `_Empty`. * We now require `DefaultSignatures`. * Added `failing` and `ifailing` to `Control.Lens.Traversal`. * Changed the signature of `Data.List.Split.Lens.condensing` due to the addition of `DropBlankFields` to `Data.List.Split.CondensePolicy` in `split`. * Simplified `Each`, `Ixed`, and `Contains`. They are no longer indexed. The previous design was actively getting in the way of user-defined instances. * Replaced more of our home-grown types with standard ones. They had previously been defined to help make more intelligible error messages, but when we switched to using `(Contravariant f, Functor f)` instead of `(Gettable f)`, these ceased to really help. Now you can define even more `lens`-compatible types (e.g. `Getter` and `Fold`) without depending on `lens`. * Replaced the use of `Accessor` with `Const`. * Replaced the use of `Mutator` with `Identity`. * Replaced the use of `Reviewed` with `Tagged`. * Removed the deprecated `Control.Lens.Simple` module. * Repurposed `Control.Lens.Combinators` to re-export `Control.Lens` sans any operators; previous residents rehomed to `Control.Lens.Lens`. * Added `Control.Lens.Operators` to export just the operators. Varying your import styles between these supports many qualified usage scenarios. * Simplified `Cons` and `Snoc`. Now they must be a `Prism`. * Simplified `Contains`. This necessitated losing many instancs of `Contains`, but makes it much easier and more consistent to use and instantiate. * Simplified the various `AsFoo` types in `Control.Exception.Lens` * Simplified the types in `System.IO.Error.Lens`. * Merged `lens-aeson` into `lens`. * We're exiling `Control.Lens.Zipper` to a separate package. This will let the design for it iterate faster and let us explore the trade-offs between the 3.8 style and the 3.9 style of zippers. * Generalized `alongside`, `inside`, `both`. * Switched to a new `Typeable` version of `reflection` for the harder combinators in `Control.Exception.Lens`. This enables us to comply with GHC 7.7's ban on hand-written `Typeable` instances. * Added a `_Show` `Prism`. * Added `Control.Lens.Extras` for the combinator names we don't have the gall to claim outright, but which are consistent with the rest. * Renamed the constructors for `ReifiedLens`, etc. to just be the name of their base type. * Added many many missing instances for `ReifiedFold` and `ReifiedGetter`. This permits things like `runFold ((,) <$> Fold (traverse._1) <*> Fold (traverse._2))` to be a `Fold` and `ReifiedFold` can be used as a `Monad`, `Profunctor`, etc. * Many performance optimizations. * Switched to `exceptions` from `MonadCatchIO-transformers` * Added types for working with `RelevantFold` and `RelevantTraversal`. These are a `Fold` or `Traversal` that always has at least one target. Since `Apply` isn't a superclass of `Applicative`, you occasionally need to convert between them, but it lets you more readily work with less unsafety. * Changed `unwrapping` and `wrapping` to have the same constructor-oriented order as a `Prism` and renamed them t `_Wrapping` and `_Unwrapping` respectively. * Drastically changed the way `_Wrapping` and `_Unwrapping` are built to get much better inference. * There are about 15,000 lines of patches over the last year, so I'm sure we missed a few big changes. 3.10.1 [maintenance release] ------ * Compatibility with `base` 4.7 3.10.0.1 [maintenance release] -------- * Compatibility with `text` 1.0 3.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-5.2.3/LICENSE0000644000000000000000000000236407346545000011665 0ustar0000000000000000Copyright 2012-2016 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. 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-5.2.3/README.markdown0000644000000000000000000001714107346545000013360 0ustar0000000000000000Lens: Lenses, Folds, and Traversals ================================== [![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/lens) [![Build Status](https://github.com/ekmett/lens/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/lens/actions?query=workflow%3AHaskell-CI) [![Hackage Deps](https://img.shields.io/hackage-deps/v/lens.svg)](http://packdeps.haskellers.com/reverse/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://raw.githubusercontent.com/wiki/ekmett/lens/images/Hierarchy.png)](https://creately.com/diagram/h5nyo9ne1/QZ9UBOtw4AJWtmAKYK3wT8Mm1HM%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 :: 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 `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 `makePrisms`. e.g. ```haskell newtype Neither a b = Neither { _nor :: Either a b } deriving (Show) makePrisms ''Neither ``` will automatically derive ```haskell _Neither :: Iso (Neither a b) (Neither c d) (Either a b) (Either c d) ``` such that ```haskell _Neither.from _Neither = id from _Neither._Neither = id ``` Alternatively, you can use `makeLenses` to automatically derive isomorphisms for your own newtypes. e.g.. ```hs makeLenses ''Neither ``` will automatically derive ```hs nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d) ``` which behaves identically to `_Neither` above. 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. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through GitHub or on the [#haskell-lens](https://web.libera.chat/#haskell-lens) or [#haskell](https://web.libera.chat/#haskell) IRC channel on Libera Chat. -Edward Kmett lens-5.2.3/SUPPORT.markdown0000644000000000000000000000131007346545000013566 0ustar0000000000000000We currently maintain 2 versions of lens: We have committed to supporting the 3.7.x branch until GHC 7.8 is released. This version is at 3.7.6 as of the time of this writing. After GHC 7.8 is released we'll continue to support a version with GHC 7.4 support until the next major GHC release occurs. Practically this means that there should always be some version of lens in a supported configuration across the last 3 major GHC releases at all times -- counting GHC 7.2 as a technology preview rather than a major release. We also have committed to keeping the current version of lens up to date and building as part of [stackage](http://github.com/fpco/stackage). --Edward Kmett Fri Mar 29 16:11:41 EDT 2013 lens-5.2.3/Setup.lhs0000644000000000000000000000017307346545000012464 0ustar0000000000000000\begin{code} module Main (main) where import Distribution.Simple (defaultMain) main :: IO () main = defaultMain \end{code} lens-5.2.3/benchmarks/0000755000000000000000000000000007346545000012770 5ustar0000000000000000lens-5.2.3/benchmarks/alongside.hs0000644000000000000000000001023007346545000015265 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Main (main) where 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 -- | 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 a -> Lens' s' a' -> Lens' (s,s') (a,a') 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 a -> Lens' s' a' -> Lens' s'' a'' -> Lens' s''' a''' -> Lens' s'''' a'''' -> Lens' (s, (s', (s'', (s''', s'''')))) (a, (a', (a'', (a''', a'''')))) 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 :: IO () main = defaultMain [ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", v), (w, "there!")) , bench "trial1" $ nf (view $ trial _1 _2) (("hi", v), (w, "there!")) , bench "half1" $ nf (view $ half _1 _2) (("hi", v), (w, "there!")) , bench "compound1" $ nf (view $ compound _1 _2) (("hi", v), (w, "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 w = 2 :: Int lens-5.2.3/benchmarks/folds.hs0000644000000000000000000000574207346545000014443 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} module Main (main) where import qualified Data.ByteString as BS import qualified Data.Foldable as F import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M import qualified Data.Sequence as S import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import Data.Vector.Generic.Lens import Data.ByteString.Lens import Control.Lens import Criterion.Main import Criterion.Types main :: IO () main = defaultMainWith config [ bgroup "vector" [ bgroup "toList" [ bench "native" $ nf V.toList v , bench "each" $ nf (toListOf each) v ] , bgroup "itoList" [ bench "native" $ nf (V.toList . V.indexed) v , bench "itraversed" $ nf (itoListOf itraversed) v ] ] , bgroup "unboxed-vector" [ bgroup "toList" [ bench "native" $ nf U.toList u , bench "each" $ nf (toListOf each) u ] , bgroup "itoList" [ bench "native" $ nf (U.toList . U.indexed) u , bench "vTraverse" $ nf (itoListOf vectorTraverse) u ] ] , bgroup "sequence" [ bgroup "toList" [ bench "native" $ nf F.toList s , bench "each" $ nf (toListOf each) s ] , bgroup "itoList" [ bench "native" $ nf (F.toList . S.mapWithIndex (,)) s , bench "itraversed" $ nf (itoListOf itraversed) s ] ] , bgroup "bytestring" [ bgroup "toList" [ bench "native" $ nf BS.unpack b , bench "bytes" $ nf (toListOf bytes) b , bench "each" $ nf (toListOf each) b ] , bgroup "itoList" [ bench "native" $ nf (zip [(0::Int)..] . BS.unpack) b , bench "bytes" $ nf (itoListOf bytes) b ] ] , bgroup "list" [ bgroup "toList" [ bench "native" $ nf F.toList l , bench "each" $ nf (toListOf each) l ] , bgroup "itoList" [ bench "native" $ nf (zip [(0::Int)..]) l , bench "itraversed" $ nf (itoListOf itraversed) l ] ] , bgroup "map" [ bgroup "toList" [ bench "native" $ nf F.toList m , bench "each" $ nf itoList m ] , bgroup "itoList" [ bench "native" $ nf (zip [(0::Int)..] . F.toList) m , bench "itraversed" $ nf (itoListOf itraversed) m ] ] , bgroup "hash map" [ bgroup "toList" [ bench "native" $ nf HM.keys h , bench "each" $ nf (toListOf each) h ] , bgroup "itoList" [ bench "native" $ nf HM.toList h , bench "itoList" $ nf itoList h , bench "itraversed" $ nf (itoListOf itraversed) h ] , bgroup "sum" [ bench "native" $ nf (sum . id . F.toList) h , bench "each" $ nf (sumOf each) h ] ] ] where config = defaultConfig { timeLimit = 1 } l = [0..10000] :: [Int] b = BS.pack $ map fromIntegral l h = HM.fromList $ zip l l m = M.fromList $ zip l l s = S.fromList l u = U.fromList l v = V.fromList l lens-5.2.3/benchmarks/plated.hs0000644000000000000000000001642607346545000014606 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Main (main) where #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif import Prelude () import Prelude.Compat import Control.Lens import Control.DeepSeq import Criterion.Main 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) data Expr = Val !Int | Var String | Neg !Expr | Add !Expr !Expr | Sub !Expr !Expr | Mul !Expr !Expr | Div !Expr !Expr deriving (Eq,Show,Data,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 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 , bench "universeOf plate fibExpr" $ nf (universeOf plate) fibExpr , bench "universeOf Data.uniplate fibExpr" $ nf (universeOf Data.uniplate) fibExpr #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 ""] fibExpr :: Expr fibExpr = go 11 where go :: Int -> Expr go n = if n <= 1 then Val 1 else Add (go (n - 1)) (go (n - 2)) lens-5.2.3/benchmarks/traversals.hs0000644000000000000000000000617607346545000015524 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import qualified Data.Map as M import qualified Data.Sequence as S import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import Data.Vector.Generic.Lens import Data.ByteString.Lens import Control.Lens import Criterion.Main import Criterion.Types main :: IO () main = defaultMainWith config [ bgroup "vector" [ bgroup "map" [ bench "native" $ nf (V.map (+100)) v , bench "itraversed" $ nf (over itraversed (+100)) v ] , bgroup "imap" [ bench "native" $ nf (V.imap (\i x -> x + i +100)) v , bench "imap" $ nf (imap (\i x -> x + i +100)) v , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) v ] ] , bgroup "unboxed-vector" [ bgroup "map" [ bench "native" $ nf (U.map (+100)) u , bench "itraversed" $ nf (over each (+100)) u ] , bgroup "imap" [ bench "native" $ nf (U.imap (\i x -> x + i +100)) u , bench "itraversed" $ nf (iover vectorTraverse (\i x -> x + i) :: U.Vector Int -> U.Vector Int) u ] ] , bgroup "sequence" [ bgroup "map" [ bench "native" $ nf (fmap (+100)) s , bench "each" $ nf (over each (+100)) s ] , bgroup "imap" [ bench "native" $ nf (S.mapWithIndex (\i x -> x + i +100)) s , bench "imap" $ nf (imap (\i x -> x + i +100)) s ] ] , bgroup "bytestring" [ bgroup "map" [ bench "native" $ nf (BS.map (+100)) b , bench "each" $ nf (over each (+100)) b ] , bgroup "imap" [ bench "bytes" $ nf (iover bytes (\i x -> x + fromIntegral i +100)) b ] ] , bgroup "list" [ bgroup "map" [ bench "native" $ nf (map (+100)) l , bench "each" $ nf (over each (+100)) l ] , bgroup "imap" [ bench "imap" $ nf (imap (\i x -> x + i +100)) l ] ] , bgroup "map" [ bgroup "map" [ bench "native" $ nf (fmap (+100)) m , bench "each" $ nf (over each (+100)) m , bench "itraversed" $ nf (over itraversed (+100)) m ] , bgroup "imap" [ bench "native" $ nf (M.mapWithKey (\i x -> x + i +100)) m , bench "each" $ nf (imap (\i x -> x + i +100)) m ] ] , bgroup "hash map" [ bgroup "map" [ bench "native" $ nf (HM.map (+100)) h , bench "each" $ nf (over each (+100)) h ] , bgroup "imap" [ bench "native" $ nf (HM.mapWithKey (\i x -> x + i +100)) h , bench "imap" $ nf (imap (\i x -> x + i +100)) h ] ] ] where config = defaultConfig { timeLimit = 1 } l = [0..10000] :: [Int] xl = [0..100000] :: [Int] b = BS.pack $ map fromIntegral xl h = HM.fromList $ zip l l m = M.fromList $ zip l l s = S.fromList l u = U.fromList xl v = V.fromList l lens-5.2.3/benchmarks/unsafe.hs0000644000000000000000000000274407346545000014614 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main (main) where import Control.Lens import Criterion.Main import Criterion.Types (Config(..)) overS :: ASetter s t a b -> (a -> b) -> s -> t overS l f = runIdentity . l (Identity . f) {-# INLINE overS #-} mappedS :: ASetter [a] [b] a b mappedS f = Identity . map (runIdentity . 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 [ 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 { resamples = 1000 } lens-5.2.3/cabal.project0000644000000000000000000000025107346545000013303 0ustar0000000000000000packages: . ./examples ./lens-properties -- For GHC-9.6 allow-newer: vector-th-unbox-0.2.2:base allow-newer: vector-th-unbox-0.2.2:template-haskell lens-5.2.3/examples/0000755000000000000000000000000007346545000012471 5ustar0000000000000000lens-5.2.3/examples/.hlint.yaml0000644000000000000000000000011407346545000014545 0ustar0000000000000000- arguments: [--cpp-ansi] - fixity: "infixr 9 ..." - fixity: "infixl 1 &~" lens-5.2.3/examples/Aeson.hs0000644000000000000000000000123207346545000014070 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 (ByteString) -- $setup -- >>> import Control.Lens -- | -- >>> review aeson 5 -- "5" -- >>> [1,2,3]^.re aeson -- "[1,2,3]" -- >>> let intPair = simple :: Iso' (Int,Int) (Int, Int) -- >>> aeson.intPair.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-5.2.3/examples/LICENSE0000644000000000000000000000265307346545000013504 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-5.2.3/examples/Plates.hs0000644000000000000000000000151007346545000014252 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} module Plates where import Control.Lens import GHC.Generics import Data.Data data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data) data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data) instance Plated Expr where plate _ (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 _ (Sel xs) = pure (Sel xs) plate _ (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-5.2.3/examples/Pong.hs0000644000000000000000000001511207346545000013730 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (C) 2012 Edward Kmett, Niklas Haas -- 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.Lens hiding ((:>), at) import Control.Monad.State (State, execState, get) import Control.Monad (when) import Data.Set (Set, empty) import Data.Stream.Infinite (Stream(..)) import Graphics.Gloss hiding (display) import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt import Graphics.Gloss.Interface.Pure.Game import System.Random (randomRs, newStdGen) -- Some global constants gameSize :: Float gameSize = 300 windowWidth, windowHeight :: Int windowWidth = 800 windowHeight = 600 ballRadius, speedIncrease, losingAccuracy, winningAccuracy, initialSpeed, paddleWidth, paddleHeight, paddleSpeed :: Float ballRadius = 0.02 speedIncrease = 1.2 losingAccuracy = 0.9 winningAccuracy = 0.1 initialSpeed = 0.6 paddleWidth = 0.02 paddleHeight = 0.3 paddleSpeed = 1 textSize :: Float 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 :: Stream 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 :: Field1 s t a b => Lens s t a b _x = _1 _y :: Field2 s t a b => Lens s t a b _y = _2 initial :: Pong initial = Pong (0, 0) (0, 0) 0 0 (0, 0) (return (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 %= (Pt.+ (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 po `at` (x,y) = translate x y po; 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 :: IO () 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 (Stream Vector) startingSpeeds = do rs <- randomRs (-initialSpeed, initialSpeed) <$> newStdGen return . listToStream . interleave $ filter ((> 0.2) . abs) rs where interleave :: [a] -> [(a,a)] interleave (x:y:xs) = (x,y) : interleave xs interleave _ = [] -- Assumes the list is infinite. listToStream :: [a] -> Stream a listToStream = foldr (:>) (error "Finite list") lens-5.2.3/examples/Setup.lhs0000644000000000000000000000016507346545000014303 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain lens-5.2.3/examples/Turtle.hs0000644000000000000000000000244507346545000014311 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.Class 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-5.2.3/examples/lens-examples.cabal0000644000000000000000000000306407346545000016235 0ustar0000000000000000name: lens-examples category: Data, Lenses version: 0.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Niklas Haas 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: Lenses, Folds and Traversals . Pong Example build-type: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.5 , GHC == 9.6.2 , GHC == 9.8.1 source-repository head type: git location: git://github.com/ekmett/lens.git flag pong default: True library exposed-modules: Aeson Plates Turtle build-depends: aeson, base >= 4.5 && < 5, bytestring >= 0.9.1.10 && < 0.13, data-default-class, ghc-prim, lens default-language: Haskell2010 ghc-options: -Wall executable lens-pong if !flag(pong) buildable: False build-depends: base >= 4.5 && < 5, containers >= 0.4 && < 0.7, gloss >= 1.12 && < 1.14, lens, mtl >= 2.0.1 && < 2.4, random >= 1.0 && < 1.3, streams >= 3.3 && < 4 main-is: Pong.hs default-language: Haskell2010 ghc-options: -Wall lens-5.2.3/images/0000755000000000000000000000000007346545000012120 5ustar0000000000000000lens-5.2.3/images/Hierarchy.png0000644000000000000000000063061707346545000014561 0ustar0000000000000000PNG  IHDRf\1VIDATx콇sɕ&~"vonJ+VڑHx1o4~8z'HЀ !7ڡewBduw5Рë/|eˬ:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:蠃:q'l&@ //:[}|@ [??Ă I @>`։34I  ي@ Ă@ sXL\$dX@ B@ PbA J,p @ z @ ?@@ ( I, 0?EbA")Lf'ق@{|% 5}T6t:}a=X4YM3[]%77ƥN T( 9M/{d͌]Ϧ4LVt<ޓ9Q8ğ/* a.Q^n~W[.M.xar ٸN֙7og{ǿ7WIĂ@N BKsY{s З[|iV~#KЛXsv'oy,{b cb%~͓c_^>^kϷ͜8u]wُglO0_|}fNnm>Q~D]|+ol3W $^ Y3Ncp}%2PS;. 7dg/oiX8Ny%mZ+Y5i&՜qͼ4vXe'e<ή >\6~^x MrZ(g&Qglua IDgu |y:fLs*8wb Dm_`!'/m>HP _u<_J,%pN%Xܝ2Ek]B s9:ʉ -N˫?H?;%_6]X( ti"ͮ1$cW],*?eAwLb@: 4n6$DM,J,BP꟞%\$Zd,Vu Fq4X[ykYli%H\2SsǗnO[rr[X8) PbA Ǯٜc76łqM|,v/Uw N?XtkXVtEWJǓkY=vXh ΍v%"9֎v{|DzI^4#b@[QV ?ilvw_W>\ufebLԃW|;r9Ly܍K՚31qq"x-& ;=( !k/-8]w~~ВI # rEU`N ?]xBZ0&cr8D $FP 8 U\ÁAs'Lj9mGt}&G3-FVQP8=eQ9e#z}Vb߲LoBJVmH@ MUwLn]%W4^HU69zgwGXtlLWcf^ig73j{l>/m?l<|֏_|V qݙ \LA ܓŷ[W1}w8a%yDdZ+ye󩵓Kw&sml7-^65N^)Ox`\,B&8c{\eqj3cf7/k0Qd͉¶XISe=D`mɶt9Oj{xvӋ:>Yw~bF?ul%l@ S+< " /Qij86\B?/| BGHN\:38u|Z%~>6b  R%>>0Ng}Ǿr]}iOvYzr * "0'ŀ F_SdR_3yDf,@& >QV  `!Dw|0nbbjM2Ƀف4}A"@O$hd/ ;?  苟^GppVWe7>q/TǾGnWbd_* Xh_{6@ 2a+j@.g"8.i}PPQJZI,kVUpZjBjȉVRheK8|ceOp=7 'EZd&JiX7\dqn?1&곑#sX {6ZREgZdy\`둬WAA>+,+ (UeP{ڂʕS ,xs. DP*lzٶ#ȆQOC'LY'|ւ^jQy:npW& [+kY{`64D5rEK^pE7Vm|Fa6F¿}s8ܲ6^SKnBޛ%РUGQ➁x;]ꇎxGZ=uYE~xFb쵊)'"nPbV͐ iU5BǮO/E #K&:vawZm1r-?90z =ua^V6|}&7% !8%prz.8!p4@UBt RJ4xnD]gxF.rwuYbkS9V=gwF6ٴ C_~T^= u<Yb /3I,z=+vojItGHG݃n4or{\ϟK7 \c>YdzPpY}/9T2Yגma«fؼ3)~!!<|_ӕ둬ᅛG,v &fךf_hM¨*xFO_ Եx3 [|z:رP a7,P'_o2r6:;+:x:ƐghlG 'DXDk_4v}F{OwerO7rcٛ[CpW|>#s>xeap\\QZh,xȸu1 xf큿K-n_ݝ]>~ut $?)^ V_EC7R{*džX't^s|G`1XyJvT4{Kozc` db ـoEfߵ>4+CpW}_>Ϣ~ ږqXSn>#w v5Gުy0`T3 oIbb&<ށ7x[ iۂ/էʃIaOf A(>-fE!m|73x-'-k2l?=,d= Qy ģ)?3sӲ3^rrjXol7{ݹoǃ Dk\HHz Ӫ3( yp6ĸ\َ@ס;QWG׶O~k g_xUpyxYssX$m1sm_* O{{7e Ǫ=cG, 9;<eyc#$Һ^bj|z++_/e]|^xm(ڮ`ɮ\.\LA ̵B 1D 9` =b@8G ] ]q7 z!@ @}WpPM,"&x_ko09~(02?rcEC@n{LX3DߝH*'L-*F8߉Z~J 7>c|t =X3u@=psr*K_:ra'|՞#w#fDyXXm~7p;QR㽜YɳAlrF$bŽ_OX7[}w,wR7Yw&ϕ:_spoJ,@@ ( %آ6F늝>kڮvTVg4N,p%.@ ODXn;=p>ӣcj3jǓJ}tMܜ8<6w&ڏ=c=tJTѭ.s߯O #+vqO(;Sogg X @ ?\*N-}2?[$E]BuFwex(cMKX /~&Z_ ݃HVk붺Kk{{HDnfe-W~kU>$z@RU74t݁ g_WmOo㵯&W?@@ n+*ڽCL,Jjz>;?Y{~D|?Yvƍf?j6v"[3Z;'L,ّ|K^Cַ[9:CZAzIu穏 Ewnwo mW e坑קv`~X?? A{+Ό6 >_@µ!.𷸲O^.ݮ>Ե7l)ڒ4eJ|p?Tb| w1.'`?чw)ԾDhXeL~_$e}HzeɄԃkZKOO}c~%dT@  _!ŗ82z#E$~yʁ_:.U5ZrrۏWHv6B::X (FJ,G}|tp Y};Y}dyO'W[\WcAtDgVΤT\au<#r# KA30gy[~'">)= c_fN:R>l!s*Ϗ3 QL㵡Ol!I٩+><'ۣ! Aʯ$\6{ d: ՟Žxli4dcr6zXA1X\gN_68WBHEr vskaCy #ϥ:>WW"O ܹwa~Bwb.xcمmGsb9̓>wZ3q%S֋5^\w:$xba:57^gfa[sՉ\dzklZ]y<0-r#@[{ mH֤/6r+6wY\ (+!Qr@nj[.Q~{MMfף As&Hϒ!Af{dńC~ ِrBh'b( K,\ӂg!8Fdx 6&_4@ lNV6$u"u2ϯjBdfXhj"]9z"Jkj} ]K,@u>qܨj3p3jq WG@#H_%G/~r_r V'UN~`[o $drKY`.D}# c_ϐeXLMz'^#PbA "WQa?'X9w,~V`CB#nnE}ۏdUd󠛕ʂA!ㆃ1I,Dˁ-0sc܉6cGe˺r`B 0$@JnLrWv'Ӏdr%iɃV"C/_GPпG<u2B?!ة ՟j2i"Tb!VaF Bi  BIv>W"M=Dk&!'^#3N^1Vͷ^C|C}1gj0WdJ,pv6:,=i\#>q5Ƀo| UA+ #-q ,ć1>++/ ͎dARXGj'FݍxӸQRYu+_(X2t[] =" t<ʞ\xŭG8$^e#C?6!)3(^?%Cl#Ys]*vߠ,,' ԇ:j\Uݼ @N`yJt{:ML,㣵wA3B,WPc'o=[)qg燗M`ԷrN&)z > Ӷٱu8uӠA37L&aX{osqNOaGu:Xfn]Ai]+>-/cص4j87}a?94 srnXcIcYEnŬ3?{e3}wh'b$d8wk DHBNr2dA:IfX@V| Wށ~91qAtH.P)S KZιnQṔ!l\5-FgzA;̲1N^.!'ez_(R'?v c@Nݢ+)0ިv*{9!1$ly۠ KsXmEnz -{ZXnCobqYw +^d!`u]$'">QQZ|jfc4{ $HTJĄ@URۇ r9PDU9y%Sm$umfN/7'U7X |P͊wyő`"aͥ'G8 6^A$!OVq-|m:A‡D󶮔{3 [ S\ *ߪ~H~x_+y HEPX\GX_< !<^)PVΧUy+a)V>WxQEBq1hL~PƺMDRH+j˥w6Frb>/BsH>Tc>l#xs$ P'v W(nzƉ_k#Pb!;l=-O-hrgaSjz\5zŽ_s,F Wufr_:d%DI*mJ]ɩwkUo<3S]$pbG 2ЧZHoru)r5HEK u$/d-w^Ȩv:ڏO,V u,5@]W%X3jܵ&_j_PfIO0.TY1TZT/я,=5\T2G$Y'bު wz @ ?0'"8}-lɉl|x5W^ .Coz^2 ,ݕC#jІsȄ`Pg6c$><`A2l@"l0ׇ6Bɑv \-y2׫3vHU-cj[!V )jb5^?nC.?5`Y.` dAOum&͗v1) ʁyfl0;cD[")o_?WFTau\klPx ;m[|q1&;J,0O G|>ȫjbCuӧ%XqF}^XtbXM"PB].(.^B*!ٱ2,sAbX`u ,+X[X=-+;jb YY&$عON,NBŮVb22}*3 )"!` v!Zm&ZE,v;q Oվߑ_B$ $)t7;-@ vv ?K$d=Dh/epڧ+CX@iXT/.cI z@_D] PbA yX C>.ÇwN&񪒼[lnB \$e׻L܅";P/_1v)5ಱ|[v;|؃v7 |*nw y;wW* ԩ ԍPAܾi ^o=i9~6]A>Pjlr, ~1яk[Lo(mvmgȎݚF6 '#d|g!FxE]r^\UgI#V:cܢY۰ۮE{?}ySō@X'@vI;-6{,`-\EBĂ@ 'Η&Hbh+ _3Asͮ>;O2 zgۏ$yFJ?Fw3˙HufzLkYNfdzk_FBzmJ,V0|mK,$;rZ$II,v]\n %@>`ཆ>`';PnnwlEbA"yEbA J,p%FD{chkp{9~C5v;54X|ԷB 7t;~Lvmw43F>p?9I,@N߲􍇖Ls;~lYڸ|qڷ],빍;?x?G~ b t*N߻t=\2 N%Wن>J0 J,$ÛAԇ=Aխf8kv;Z~--82'w}l[2۝i_=[8/9,[#gm)Z4B,n-|!ѧܑR;xj̃׭\BܲN_%u02=#|7|ǞWőUn1C>kEL=!+@i5Nmܛ}cɡٴZ(I=Ծ"h]cX?6QdW ݮǵV|Yf|2~y}#ǒJ9Wie\pM(?ťsVd-ܒ?cA]9oq?͎L, ;S59nC|׌knIs;sX|ѕ11! ߾?nDrnC&#4_oC>vW;_sկ '?ߍ:6hH*D{D@;Jq g"e o9~?wKbX,71-}ۯh8?EU$)@`YT 8\84!/^1Zy -cYuP֏_4GnAE=z;c}1'p# L}~s|w{3CC TDXPeCQ $nH,0cblc0g1weNؓxw-ȂMQ}žPmb!ü8<mk tAd`1,i* rqi}?=! kG=€O V ~ա],v 'qí=Au1MU㷄}oY )QnC&$(&/8ORmObh,D's W]MFLJ1EЄ^N,@683kX-BE,ih0+q> ]yMkxj~Z43|ȧoႪvGP!yC@Qc rcP\KmIo +m2)q2 !P5N}ԀCza|q*ʜo  ΦV9Ŋ^H`_9O¸Ac ;]/.Fy=zA2+ &VVqֿWM@q{6Җ18ܠSe? F}g oTA>umlR)>Y!X~|5ف+;p(ӃDBȐY\;4\ʂ{CpE Up\w ۈs/Ðqx9$bK{u isfx6UN[Oexm)Fwm X }Y h7Vx|@ %`pm^i,1z=ky-I^Ư# `!t8>ԅ |[cЊɚWeSM-hiuv,=U^KB qP2my}щ!@KRZ7Lkɹce`fm[p+^攬j9UW7 n Ye>\g[Sk,쁾eyAӜ6{>=$nXn/g;Gц<l6F1j?S Zerﷃx "æ6B4ПXDKFð3p< ]ge;k[Z>uZlv79ce'K H[k6x|M,@ -1 dj[2=5<"@]xa'*1!1cX@PlXT4%4ծ%Sy`Im Hbfedg+ǤXÅ]1DK.sjnY 3 P:C^3C: 'jHE?!@V"^pBv[}5*=TaW!A/1v.!=e,lg,iu97gN(w*x+#BdZڍ?\b6uڦp_ ph` %TWY=Bc{@ 8 3>AWռ&;t MgQE r3[Z 57r89G`υOm Z숵Ӓ^ }D&؞^s ̓ vr9ߪ䒃ۓHEU}|ByheW7U `H9׿>WyAVP_(rUȷro^ &@ /r&f:Zm߼3mE&vo1[j'׌A5l JC@z*©' !w ~ja(b9oY5ԛEV,p U6BI!TuJ,@nS_AEyqA!|]] ȅ96@kp瘴nl6P_W(8 ;Zy!Xۆ@S֫6?ƭ| \$?UTsT1YpD`YnIJ)|s)WCq$Jd^ƫYN<`_aõf3xe쇿vً :CO]F-'+R~K$u&M+ w¿}xńh#𙎹I+s'cE'A<<f6,=FOrmvKTmGj9cQWc-*DJkqN8xuѡ[/{yN@EQhx#DoѴ2IGmc|Xk蚣pۖX Ww02D:p&sPHB 5'w(akOT /ʻo #uɯ@:0X&@ OM,V0|}Xt{L=vsѣy;=@ ?Ee{M^SG+>C (;Sl찙Õ˯;wXo)j_g|One β3>[*BW֠٥Z?4نpm<\L{ӄom}*)1CkDP襬Mla&z13'"` GzQdvXؘ@}L c$QſdI`[oT@rvcvq5X:/78usʹDwP3 Ģ$C?TfȯqCg:FbjkҺ3ʟLUt5hyo% V;mOMG~'1@g@.WXg)0yMm}pjAU2C$=/QňW[;/H,Z&8Vh ުOBz1!AzcIԏ#V410/ LNLL*t%(pv0F%\-ٍYU@\I,+A#Hrb| J#LV۬nNhC^$;̢pz ڳתmZ+Nٟu+r$KrĻuh8TkLN,V亐QbA ܟE(~+*" >Fu;;؁@P/|L HD YXPg^n'ȼTπckx0zAz3o-=Co .αs#5>eU/csm6c@!ؐ嘍A0 DBK7?ze6 |;\}0ut ӃWP(n\"x(˩ރL"(U'dƻ|a?xb |#ǽO_˨/od?@X[W&p/o.x "`~2{~F i5M/.Ŷ# ,}2ɉF(5LlL]P _D~%J,p G?$VEp[㳝 oJ4p @ kf8 T}m@LKcnq* n651ܗdFuŨNV'>둔h&| !+T4 nOLdA6F 9O,yjyUh8 P_B>`B 0/U(@ 7}ba꿓hvi9%; {^.}nSa;^Vs~thÏdKp$3}n|zE܇Sy G.>j6z*YiWuʼnNK( Zayۺ^cRO^ci߽gcӼ2pLPS^.Kw:{3w~;x8Z6fg*S,>xÃ~@{{WB<<훪-ӅvAr1 |) ,l ܗ?{$|P ~#Vcf>A?IVIpH,_k&Zcrٴj.3F*>~M$٥۾jدc;&跟uD$G|z;{0GdZ\g0^b"(@IW-ʹ533I ۝X\j<˳G wGJ,W+ɼu7'p >Am-"p^66I(Y>She_LląՑpw pV" +MlbuYXՅC h dފϪyLPj3hxw^u"升WxUMf8H2"+@G.UXA}u=,0l9z݆h0x}Otm8cyAu? uV~cW*Gˬѱӈێ '綘 _2H,,k(˵2^w̴D?tzsP ;ZnRˡMRokK/0 ?Zsޭa{RAD]c_/{ڗဍ]q-_}v V2=!]aa?q{鑛o.9Ƀ}D cE'EaWN)&_9'}85p4_o5ö?T6v:^_|,8Ta =Pf߀=>d n=Y*)h\5}8S1_1hG{>Seb$ JXYl᠜XȓIɃ|Su;cB ` hJ2ꙉD@آ<[]T?  sH$ pPZYJCNU%M͝-Ju# `kU'=ΐTP>8#SkrCYUV%9:չ:s(WX rb28%-^?z)ьgL!կ5c^w.bIpr&: ׻KHz,Ya|CsCۂa(sp'QQnW^5~MoG_0˺СB#lL 55V,d+ $4 3a& B;2Dp*ĩ>xHjnTMK,CՉb+jXV>H>VȜz=H$` }dge"B_6rkS%9Q3Y OT[T'!l&GAYm!e&-Sՙ!|X-_ǼXRRx;pEc%+'pZNvt~ ,TI_0kghڋ ½X`QoFUtĂxZ@ ZF0- XTI ]: ʣ ֒*V9ZMLmKe2lZLSY0 ǓYel pÎp|u>Ϋ;O= 3=, rYhyUM{kzp> uÞmNIci610S0 kd1Pz\}4솑|ɦn'V:ˊnW,O/#v|}R MH6!agn BW'><胬Y%]@=yF uE|Ӌ1tj2ΚZgu0(gHǫL S Rz6GV~?w>2 \,߅Kh,rWKh3smjhyUmWHv~ G̀{1c!lc7B,|@􉅉U9<r0bB@_g}ozd~3jtA"Y<^$+3*_#%[.T:C(ڼHD HJaA twss`]j,ȝICϨg"h!D@Ort|)WLYA:@S!_ѣNT?]J%!1 JgSdx|wce"|l>YGCvNhoC&Z*/*qm:ty'p21E<΅v$+,-@JFgzKVBbv[9%$$$fmaqÓ ;'<.CB)&o`^XN%$텅vܶ.9%$$$fw pZXHYIHHH̽ z=0.+Ap0YBޮ )cvϘ1;ui|$!⽉=/o?U6y74Co9}Lg\ӝDb@R {.)xm4xWW^yJC7%H˛~{ē >2J,cE=դw츉_d`1P$bpjH*-T:|ZƲH j\ 1" ?Z|n[d=y,>;2%;,m(ks$KgOmj߅DNu,㓅~b|@C"D^oe&Z 4o(o:F#=<x~{1!L%;%c YX,^(ϺJڮt+HL)x wv-=7r f2@;i5 +Hce aNӋ{EM]gRd!ЅW|$WDzyxɕumz'J inюAwb/N+2D -mixxoQ‚O^(:m8\GtSP6$߽['wn諸)s{'.1 ^7vH ϶d p v癊^k]%8HdKmD_W[#Z-sP->q#3ZEV8F[ }a"CM:%˅NJ di1K~`#1>QOcdF>vOo|ኦpvRao ކp>GfӜC2;en>[s_jp z10m܂__۟۸ -_>q"9 ^D_Տ&&ӿW_L%f|a'Vӆ3#58 $Hq 'Pa?9rJd0#J.[G0 m\mlĵjR)6"{TӋmrjň(V03H%CfE:Pr'Y=1qY`OM+;9\.2uZ܇W/!xAk<]w Z}eFhdH2X0>>G Oztc ;  /;?BXX`Lhںs8$@۩^jVXZW|N(qǃVVA:Xj ,{~0&`]MTK=xLրr|^ÿX m@Ю֣\#뾲]i8CJ4@Wγ|v=[iWbRX4yw&\Zd+2~B Af.t|`8&+!^qsDĻE-/K;! [ Op SiPQ߇ʣP7]k~Sm/xz|Bޯ?fn<6+grZ;뛎Iv P[ 2m2xHn/eDH8GvK?LpZ}l1ȷ{0ju]^܏@q+ߊBe}a-H: ן7{ ~&{n^9Qm# YV÷a_X tO5?dEtZ9ja3fcJ8  @lLE{|wX2cZ5unjE$;&9>sx)qO-k~j2g[~t:m2H‚5& ): (`R CB$Aq|* R:I+&WtfO/O s??9/\@pӢS~ {k}\cc}ʜm1h\T쀗;'j1h GXĴ5?>YXhSjI/S !|hHͮ),gZMţhQDos-hGBLXRZ:bHyb\XZl$_ՏNMW2s YX$ OƃQa:VxhUPj}71قϴ޺:h Ntij`@YlãL`܋vCb@{$9 'V<>38 GM33hpM c> X{SR'ؼ ;Ѷh|H܎x J);=KTXZbPZ;\~Ӄ;Zv$n*PDccuΒXhtW-qe*"%$fdaANN1pF }ä9 GpoN/nl0ixM?1J N gBy{e1 I-4*ҿ"e4kXg+Ŧx{8r8Z-}ӍWE->VǍ(p?mb p֛ʏ㓫9y^ y9wE_a^h+< WF6Ւ|FC5 DiinI-~ mInd(}=10nV7q\4'+ق彑ybu"xGHtw\ZXq"t BxcHB{T pvy %c,ֵ?Bx"޹#xd>y` ţȑ+bƍ}׭Ѱ~>R:g~yh_ĕ ^2YӅ37sPy+ʏ̽u#|u3~?Ey<|}?tSe=kA*em1gז&B·t~;:嚮G~ZZd`7ƅWj:S-޿tEw]˅&eUR+lp΍GKz'?ӛl?9*1:vj#do>XT1߬=PxTVfOkAK}%O]-7tӓrٓ7v{x | C^u[q!de#}&jeMau*H:MD]~nGmN] WƼBu7Dю4>Qe31QiY}NMήpzFb;hOAYW|\禈Bso8uGu.87)#+Y_^/ZtdPK\ x>Kbzc@R = ;i,nгxǕ#Vǐ tp mfᨕPӤkx464r= d"&g,A͎#L,S]3_N/,85`h4/iuw7h`קӮDٝ_1q=?uΆՏ&N=P .9&O}rlTvD|'Ϭ ~{\׋ķVI|4ZP߅Z "s@ڕz0ֲ%g獤QjƣEn4v ¹]Gq;x}vJ[7PTiWspvtHHHHHMh-,$$$$^ -,7&3{l0Gz򐐐]WX }㣣kGU[FK+ޱ'><2 &EuTi&=f٪fK"B?ݗl~~%%da!!!!!! MXxM?3/K=ɑHN&y]XT:WJvp/o؇P5P&5t7H|/|5C cn^-K;d'e,! ۂv Z6Onrxxinp"I.o͕W֋!;KSl~n$JVX~ga;,qx'>::*wxke๜ }uˉn5w7V|}/hpc lJ'Z'0;NWt~}cv_s?j_A<' /,9A.(pcYup;if'+οx|#%燠c2|c>~!q<oL>o_5Qr[K;C n@>Cgh' k B =,Yk;5F %hѪC5hlb{v_'G^ }-2>MBwEa$x}X=X-ioPlwV]Ԛ4ޢj3VAPj}z |a4#4ĤOe^or=_ݩ5)Ud Zm>8A((|sXF.}AcT`)M4n|t.')+,%қ5?3o"έd{PJ@5b_?zMu9AqĒ|\{KbqզdkYAc*c[=:XɺnvgYe&O^?}r×Orb}4Ķ|_kY,q}pdX۩2-j5^jd=l:^ޅ1gGyK&9~rp֋6A$$$$$䝰al<+%Z-P;1Eib5$W-=?H,tpghGDYWh2>MV Do׹v "f^]kƓ>n}$=0amn[MoFMW4׈M>eC& -]q|LL!:}Tb,,$$$$$Xa  LX0{OBBBBBwaay\g|SvN$$$$fsa`%$$$$$4RVs.\X7,ZaMXt+VwBmg3Z )+ VXxã#uigO5ij˚:6l1lESe篝Lo rD ~1k<+NwaAOz|X#Ijre_\,,$$$$$da1`V\ >T<,ޑ,KVN9_?<>sZ<%*YƮd仢9H-4{ h_;F s*. &+,`jEe W-zS: YXHHHHH;7w=})>;9BFs YS!&o.OX7H6b_}e8%^;sl! 8Gy3v9.<8$vcg7Pc.ZsxOm B1OoūdI/rw]~{2_xczG!*Jm/9Wܙ~x(t4a~V5Ra`{VOj -@D @.9 m4N&mgM{DOԓt*2BBBBBƀ7ۣ%6|,Î㴂v72}r{We*ghv?Xwo͡NHY!r 6ŚEJmyD~ȃ,q=ǗB-߽׏wxhU?EnuX}f݅{%mt:xqPlK/peԆy睃#vv9?::L@Კ$yۭF|shF%%}y8-x?bW=LG4 })uJH7*i>3< zQ@.s;6N]yTH-ڙMOZ_BnBJBBBbŀe6zS,#a{IbK7W^omj_a-oQb_acm^Z=H|__va@<|:h-k qob45O^c`[vR &PVXA{QCj>'3]8{AvD}$BOJ",!3QK{v XZBEKbw7*u=6$-!o_9~% ,gaX \ 6dr,(,L(,^>qvQߎ{C2mD΃6̫v x|)C’uGJd;x>}t07бb[B;Dtu۰CD+KO^fbD7Q.^Xpf5+v|5_8IZگWt>ޡz$DFkՓ\BJBBBbŀ hH/)Idת=ƫٕw\c$FϘޗ:PIYPVye8h2k0 s.7z\-#ƶHIGm=<2Yo1Zw+;MYK dW9,Yɉ7JF!3kx,u3z7ڈ6́~n[cF݉6k(@asdIOs )+ 9RX RX;sl>R5~J,K>A jP‚[Z3nϒvK+ ߒu{=KؑvJ_3Atv:`]c?f B-$(:݇1>9> =ƌGI"+TX|Ho ҪX\#غ "Kz=Zx$!! 0?KHHHH̱:1$ђ6S2wQbpVpP2)'JzHZ \CR?PQ 5l_Xpz$HvŤv #L dҢs ۳ծ'RVuAQHm~U^T Xd(w,$$SXbV?/!!!!q7~FX#I4{'ZsG~ib{`1XkMAt#M6H;BKBB"\XHYIHHH̹ϏMZuv.]Z1~m)/ 9VXy5.V[;'3Ri,,d(,ZlCfi$$fFaa0:'Kuùm>¡1jn޸a&}o]wX\Krdx/.X3n `ۙJo_9ƜX u·9ޢLޕl~Zæo3?/Uzgf}!}AoJϛfĽ/K8뜷Bx7aütQmEoNK4F}Iv!qÏ5Üz#C+v=c?}pVgm]G.h8 $qU{ltSFwY_5d[y{FINpqkm7l~1&Dj>^ǭ'+}$قu>+b1%{Lkţdשe61`Z $dwBpN ~kuLIs^>=*,[ 8E8GXĐ^f#Jȫؔo3̂pI +1VKPh),x{"NJKaB:ͪpi!І?ԤdfKk(q7'?ƾ)o~m϶fub_?}|Íg|SI(A-v>RA=!fwZdžmmlZhM,#~.ٓ׉Nˇ@Oъ^3l+,QLǪӲ r-yͫ=yl߿|oALJL5jK_gd\ɉ WeU+/ﯽct__@{pW<:|B:XY{`<Rp"_n~C|R Z8Lag4E.\38)Wv!õ}tM0!H©5wFpP 8HM'&7!pY>WE?o@οAc5S;+ ϷtBHD 9,c6edW9mn &_C5yAf=!T%hE:& Fbvz0v`; }ڝIlPzE9]4H s'B",z'$T)X"HI] ="7w`:ڡF%^bc Wu]O;bbCZ*bEZ>r EvmB]//>/` eOXzl|pa=䏸P9 /), &p;P0j 9w[F~w}CͶaӖӕJ]VŹL q&lS " ЧCF3:}qغ#~fԆc 䑫.8?<:Xr~p?C.U{P 4>{ܐZdX`:Ӏ UzD<~y$hɭ| 52\*je{;M L,0?Hzh q՗zDYp*y( %ځ2gr*>{$WsBNo.87ڢ_Q.dCpOcnR<mȚ&*ole+0(iI|WKmA 8x-{Of;hW'}33Zx1Qi?6|'NKfn+/>f{Zhc"f3fVJltY19_y?.@̯Shl+9dϵ A7g9ygDo1o'jcc硲RaI ѻG Yp|.hHo>QH6o"bLOB~"Np>|3TǯFңC_1>Ȍo{#?6א>) ߋ<ǐ鱌fWYsW;xpmJ, biC@z]["O4?'oa rYLo"Kj7#h$Ǘ"Zj$=*dޮ]sHMt)&r~q.dV8oI+Mr ՆY& -ր<_AKUgp cͬl1eDcɦ. lj*[#Fx4YB;Y(q-XXg0C1 6fWVlx%1e" PT`,+ lYW& ^{( 1EZɻ\т :iٞ.(AlJ2 v2輯2Ʒ>^&iH V,Wb{Pd1'C|ߊb/Ʌltx%I/cN/t?vDÍ#ȩtY{nAjv1Cpԯx~k߼,n]6ST d;mXdɚ:hͬ3Hv6g"15h.,4Ђ?THr+; ji~ jC0`϶Oć?"2hb'xQv'Y P>/1A3Y SyS|Y~ςp*KO6?)F2 ~ bq 1o LfvHr>ݜ٥Hz 0Qh _\x#[}#Cj]%݋h*_YTc,&.+CM œrc\z-`H?,npC S~|e[2{Ǯyƕvs,97{'ﯻg:q|ϋ]7KS#L-Vhұ9s}un F[9zGһB0Z$/,@]cavb=) Gzz6ǠAޯL (e{ IeXBۑxZ} fx M|o ( 5>o^9?_Fd>spZ %{hAo,Q&j ?6h;)luhxo|c.fW8>Vqz!0v?s]w$&x6ݐ 9+/!"*-} |܋}qsu75LZ/^7|mx~AnZhˈq=kƌ:{nۂ<<6ۆ =idǷKfR*؄cyy|)+eM%~lZg6W65g$1saa5ĔŁ%9搠u̹:mW)ϰ2'vMl@+q Eb•1=,ŔJ}a s|'QX--gh_\;=@_x o qz ^M!',NN*ܚA"M Ƈb 4 sV* T @Mϒ6|IJzcP~6+#VU.D{zS68Fv'n݈v(II Bs sy&u y:ĄwnHL2x^Xh’̭ .<ǻx_pvvK1kY#&ON `qs;~?_/8Js>1lW\k,a kY2HpnoJ[Ċɍ7*Tly c\Xzq(o1=ctr Ƃ~y=x*0~ !E1AzOE|aOoC%KY(jDW9K$B+P3L00p:MA6bԂB8` ch"h'z_,E(#-DSCh'qm,K Ztic"-! 1(J$@ӢXHB3]rGᯁxW'ZnPM= aLjrIb:Aت &wP$W%da18swIBB"hzctOfX$f.L ݾzW(!q7Ao,b[n?~ő0 ̶rEKB"mKz\=BBBBBbFh9c+;)xά-) }a2.hV!#)w]TXf Zc__.ZT*m 8ql+:t~ܖq;UNNyWY=#'2hM^lLlÊ}_CsaK/[µKB"ZXh9G1zކt2Kgi*qtVlFl#|XyG Xd+b!m"@/=RlIދ ?<31 m`s NUJW-96nsu~&>ZmM¶?{pTe5l=U5 mؕxFSk;;%wO-X_1z<FOy nacK)fkn]mXW.ۗםK-Z`FlcZ~6CsaޅA '7MD_ZK/M&cFEO|L/wÇ<j-s]ާ5&! aU.EMy6#ŭDsܐ>yŀ #ٕnobmǵ^7LYuօ6FfțUL5i]t?AJk@b/^|UlW&9l2UK&)}6%vm ?b_k.Ftv.ؖ .M'{]XI;>XU㇏Ic |/ٝG0H/sm@]|g4x)i41n# g?;G}0灀f5<*wnHy؉Lp~׹Z׊>#6ofy>>>6wř^{#/ΉB\]ςS{tdd֡vufs/~q7 {йRXf_AMuW{8ߧ?9|73÷yڅ|mqH?W4^B-̍<挚6coHܦ{atOmqa[ vw:.#I( V_~Bߛӹƀ k qqMW;>HY[|a!lv1X&SC/cnd;o_8=`}exB;&`y5&AN= 畸YP7if6+4Xl$ݐ@-E33/$H-&{1iJ$0þK N7yԦi籪oTh%~0:epb;r co,QH0U%4&$~[|}%ޗv*+Onns‚* G+:Jq}Ï$A-hAl굥z!Aw*VnvZ7E$WT>x8adǐ xm  gc+"YX\0:Lj9*$ PLƉ0b<vw:.P!K_K`/8!-dMÍ%qJM#^ֽx5?og qՠ_;.`e]F "Ƃpz WCike_\H=XX,(FyAgTaQL>"!& mcsXLBa+g1ri|cmQcIm`Ƃ0f$8d[T5z5CM$E*A408p? Af& xv m aw[pvi+w$2Mп9R;Q0vr2D;Z-Z+tJr@h~c$"Gs2t +*y $LEЉo,H'nڿ[dE>x/$4aP(e*r($wd[?v31.DB$_B 2 ~p$$>RN~ah] =hb]jd0:# V.<yj'ܢyHxA;GF\CQ`,ڣHRs|&}PXxoFP!!`v ^f\꬘`^K"| aF۔QbmݕN<[5\cW:;l#V 66.Mj[+St MW3&!MB]u6 #.@GoI.?~lԯ饳_ 5&]dCcǎ#o$ o5#ˡBb>`NaBRXsܟ +p?zl X5X_p4pɈg11 =N:syAo;SBB 1E*,P$@O-!~a?jE.ګc 2!~GGhqm1 ϶f VvF84LV-9>~J|w-zh [?{j83evw~7t/ N+}D ~lH?9|?g^ HJaA`zv <{b5`87ߞdMpѴI@Km+Ѧv/&X;x)}Ej ]nOUo1\ıƐ-PEG+A%Q%^﹵>cp#ql F.R\Mw\wMl!G;V;"S6zl ȓ"je:=_>ywx{u8Km˛Nj.!"~ G |>]UG#e# i[V(A"lOOj\,,ZN Ӛlk)goLLtJ>J38gnGB%)Rҭg[O|to*cC|Q֯GRISՓЕRi&u+O(,lcxBQpGKWЩwN-^LhׇF+K& G^xbvѮk^+fm;,>ޔSLa"ƃވƟV-ܞ{}bYtJJ<{}XtMs,,Lڮ;o$Hb]W~w9MPqT>\Tye n<|@]\ ^"O-4O O{/6(p <6_;  ]: ;F`W3Zt٬9{G}ab2c@̅JHHHHI$@"N(qޫK/t!,<*_%T|8[kG2I<_%DH (-$CoƮISe[_+h hch~6th),hE})"ZPתH6W"(@?\}X",,$$$$$fDaVK(KXDB-,VaE =ce3qՅ⦮6븄K*;rVXq 8$Jy|I@ }~9< Կ=y xaIO Jfq87)DF[;+6l%Y=dmyVyl~ D c/,< ZmFۇz vxm#Mxց<ϷCa @b[R|//\(*0@;g$?`n h~BzPn*HE#DLշ7`{`p/9IHZQ"ll"!H~q_6JHHHHM$$PIY2`t=4xē@"xư-iAH"/JL&bF?:\*TQN6Ŋh8g8 Y =Ԣ` 0qbE$Vm`+Ƨ: ~lhV_/ H-vTaա)o > ]h2.?ؐOfgMۋ xmb'HşVo6bFe6~OqfL_Ĭ+,涛/oZͿ|-a{<񔞣x@a.zJڀdxz~`<*~M~a'm %~$gOo <+mZ%2̫bMo7vt/ؑ-ji-j{{uZD8 DN4A^XDO&fraUg"L2Kzea!!!!!1 $|DR"Y~cej!zuw\ -YzTdLEjS@i.$IZx@aWZTH~[Zt>Ž|UOҷ..z$i62ޑQvعZXз%2oJ`hg?;wEKEҽEnJ>Pᰍ~CLjTyI݂_k?{ue `~5|3{c[mre[``YeQY$ss`LH9@W(TUw "^@W{9[U(:Z:D;oNjc$(Q B?]xg\A;yITmѹL\=9 }R Q+jC{DZt:`5Mm)@Fb>*~Ҧ(ߩ@D6w ֌>q:,K-񽘓&ԏf8>"C_KVl4`uA"A1cŵt8OJUrc;-5pk$[)@!+fVTï^z 4o|;bKX[/LC~˽ p ~wl#ꀕyb;jgyѐ.gW[qJD|At r W7#\LA=B,K:ww7ڟP,e=8:\@{*;캋:~a@'cK1cG~ ª l';x -ȕhi I6ȗơ7 q (;_E9$n9Z8DZ5r~]uhk#b>*ԒBSLm:zPB)ҙlJNQL_c\m8fH׬ Ç&]S%j&  f @4-;tܪ pp&`P -B^+xY#3Ø} JTcA)mDC#ACP#˜{_u_\%34[dn +,tPF Fi|,C!(Ek\Œg / reGyzo B@y^ }~?fC: IX׆ XFCW @|vBa< bX1۝у_ 7ӓlõX@Zf+#=o}ĮqRC72`j4.XA3XȪ݌fJՇ|$-0A qTm$K `fXIGKFbf5HyJpbs/[%HqA5F nApk"sg1__H[Y>gx>B ꦶ%5_y VL ґe" F4[ԭ+h3ْղ|# &%ҀcR@|veW'xؕl7ɸ5/q2H:˟ +6Y:6j*}qKTHYZ$AW,qeYF^)ُNJV$b&$  Y@F2H׿Ub > tS-* ׷.Ee[m+B'/el@cUh}0i3>k1U g8v+bI, XBIl XXȬ+E#W3WͪilX {Q[NX[-o`K-<̍=8QvV)fQ?u EH>X,4ct?v]e@AysȾhC6q? /+oy~!7!yFE_U){L}"b>6B + l Dg~7)XV@z¼CY!mlBї͈8 El o ] vD.XA3XȻױY^ىVmH2 &xfἑ=XmNJX Av"@l]l0iFꇇ%2nlsTX-o{ :Z/ׁm+\=YZNy Z~#+@_:A6?|[u 'Xuۜ2>Oja^[ԲdW .(q$nYP_>֬PE bpتcZ1`_,#䃈[BABl=PE b bvbs~_5{Mh9 LE[73'HE("A1A1=|A13V{[{}lVoRl@q(ՙi#PE bJ yx 򍁱V}@oAJӜ2ެd|EIkA;޶2_75"F9Է}YޚWƆE^77)5ըꛎ5y^e-D[V?^~x%-m? JHbAAL9bwȏ:_;R@pQ- oFLZNwXoi{x<*>ctkJL!;PޣWU o$++^f: E}̾2~PUORm%ΆWh D/A !o]"FVעxX`W̭_!yrC@` 37JXLح8vɊ| Qn|'r}BR 3x~oeDЛo1|XF:?(ut_CnS(PO<L@Of׮OB ;J>VoZ=Z|iStݒ̇~z^&|ʌ rq}$ }u:q$d 킱$[cv1""$WIFc?l]$  5# vH:ov_2*p G}G<8XH0#_ŷ-Wƀic/=GyVhb Ƭ:XS&`vWL5 Xp¨_z @ƌ<1FMCfAPdV.76@d8^.ȕt@~GڴOk*VJԠL΁^o>BV /N[<+r_eG-lFb "b^'rB0C."P}+]:wzpY D(8g6>؎kehƑk3a+lOCk?$}$ }+0PE bJ C`%+ã!fGM,|~c] X ͘Agul)0@ɕ(#qKM5 +8nQ끴pZ7FV6(IOS|vKl Mf1k%Fff_:! Geh;cPLH`g eeO/a_i]R#Xƪ+;X%@XFcWE+_|ve:8Q]-QR{'Db{H Gf6FVcdUIAJWaKq%,ifCc$AĴX@GG΀5BC& qF.o8P#̾(^@R"× r!@W,0H?F J$DYqIrNV,|$0EP R0fMAF*1PFP> !`cUs)O*Њ}d^TҀ C=Q淗EV>ٌ]zaf^Y+g|dlN"njJ,vikPw%.*ļTuy9I١k j[ \X!ShƑf }:G&z3%Ʒ[]$  3cyے+m*7^k >U%Un%1s 'h1 )3 pcv&0ު A>'>+śyA0#-G`$! 6˪#}S !퟿\U B"[P aVZ >+P^#KJJXbPUnXh<0P]]MbA/P( "66Vȋ0;f͚51ۙ@P^^>`|`b…ѾMJعsڵk nN) BB#oу>8t:GM,-HW0`([[X{CiPW)BPT(@,D^P{o >>lg–P7AL"1n=/l2ȩEW4&u#/NɨￓQc(0bŐbfjT8_]웳d8^3M`ELElS}/|4H0~OD}D_M]˔ǝɶ 鹕z zZ/bE b ƼB7@',xa}ˁMcE u55w kD3A{f~ɷf͗$$8VPØ7z@pkG8z[rlhuwѡp0Y׋cWKfAT~vXy{쭰{6$ $ÎcYl?Ӂ9c=xqnA2cBdap+-B7yEu"_?:I9I3cG7,/6Dҧ$ –tcr%݉%Ü/폿S#j>~{:kՎۏ^?v>3FsV#IϩqlX_rZus.&'rZ7֡ѭyaA ꌘH(Ұ r ?7P\iUГUٝWVD$= `$߿F6KۍS \w).Ǭ ̨]Եv\3/Xƍ1]XZ ;tCJWn=ٺ}B$o=?X7D@._Q(9_iݰQn/AbAX|1K{F<]쮬nփ>ՏY}"`$_L ΘΕ"X_  zB%^y7-G$Hhˊfʫgc2zN]NgEVX>փ٬/4#kfA5z0} / $_@D jP {[ZW`˴g/  &V,|YV[|ɟs47f T\U0§1 > 3/Xt3K. _24.8tvσnϟꮩkrުgc2uW7=ܛ҈.u:#:kޡZ\]o:yu{%?-$Έ) - =+Ǵ Xtі{N%m/jǧwq&.k+`v߼3|wF X}@|^YF^ՏrۨG{3/Xcmc-55zn脼nR}K7&ϰMN ']6+WjvE_6Drݍ׊}ry?ۖ fXb " ³ jntqIAIEPV>@]r?]%/[FeW(啺@ۨw"U]~FXX  spL.8i4j$w}BhTe7/װ  ?TY㴵fn 4`}\gvMF}g )A4APĂ" CG,ZZ;: !AAHbAAbAA$A$A1͈E{AtApĂ" I, H, Ă Ă  hnmo'.XP_A"AAAL&bA1p?=AtoA( 2vWK1]  E     F,<AA ~qZʚ Ϳs.M^vv &!<ӣ@S]Qqh T~֡v 'O, QO&tW4{~4{:w۠ /v:K7{vA{=WiwkQFXL7oϟ<&=.&!ݪ=LzY޿fvfz>;}4=q7Oܪ>kڈYP뽨򚔜j??wB#VdB'CI,PpGT4>X ]hӈI,TyRfOqߵY/wlݙ, ԙ[W8'.6W&s9 R/ ńۿlLBz7)ҳxBz66]?] M${}f6qޫ &=d%w@Su,{,ꇞq,3>W|}nS)9Ɵ?cMk'M#CG,LOt#ƬVQy;#[{q~Ay^= ڠxW:;%~kn>zӷ;/j[ƽnu_kyCuQV &Kʬ~x|GEMuHy, iVEv^}6qб1Y^}s[/Ù}χ4xȤ*k.b.IMM* (A@l'H!BP"HYX_61qhh7lِm'qST=bkIjf/eWnUˍ4]C>%_/{=8w;cfCac>˽˷Gu.rUyQ&>쿕=O)g[1M hqP S@RkE#KZ|lR5?PG%N :ƽПG{!.>g.Y;&{TɪH{>?_i|Zx×!02` ~vdx bŻJ,0ϧaFD Xy.ڃ_SA'_LkN^No!D^sV4df@ګv^BsjFg{5Ћ"owP7f=V@H)˯N%@x{|_ nqF̷MT}:Fި7CnzWt'Hb//F]0Pk8]9ݵvwtJkgBZ72:SdL-M6ocb xĘ_'$p=|~#bo/<֍`viҶ#bw>k-m&H1r.~lL ߼wsz9@4+ժr3ʠ=2;{$OBrJ(0}zNoO ^_)Cm}a~T#'`>XB'c#de4I~GZ CUm:iB{k'ٕio?8sh_c{snd|_E9.Xw<q3 xA X>8#{vi쏸աp@@RY"t6E%^Wl 2fp3]c[aiq#G N`mC4ʽ8gfy [ѨC"0]]% f"PP@-l1LL +{LVBv6 3bì[P0LVNR>YeYo_aI$1 (F 5 ?Xv$P ʍ dҿh.lAgؑh8Mh׊X$觌qh~D1~P3ɮ?xi{  _&6МUE~scK`@s M޶Ge6Lna[۸2'k^=\ Yq o)4eg> ~ rs62RNhϴ~qJ,ȤvAh{ɆZz}GK[]0{ymGn`_kN0-mNsjhڙ !?Ϙ7Nn`j.q_}_o9]U㲴(Xtb8:WչP4IL+|D{Kw.VM쎪O;ogOBdEt`e|#cv@ -g0:fl"լ̱v袾Ұ XFI%#صnPNt?e6:#:Fx^++uIͩvW׶EJ@,@oL$3X;C@-&K` J{"n wPm? =ny>B-oqE0}ZVz#uyy> DQ7*AgۏK~h"PXyˤz^NTWI<x@&znjTصn>mG,*V.+bvª?x_׎-ohoVa>Vҡ ,בw%kD&yOGga0Kږm@Z5v!~]t|nW3&.n26uYjYU]^<r/~߸SK'3J|'iJ_*}ͭ=SznMێУt,ú-=z3l)p=%a;J*]u=I(4* &Ӭ< Dsmo`nrf]grn AL4$AٿJ #8)p⚌Z [ؿzzEߟí. ^jwaK#)r kA|Ab@6T-*oIp}Z-(3ʧu˺OxiݾѧAgc|/z| ?hlQw@'A}~Sz@=@S%]vvkIO2#R#aGoKA 6adD۪,vҧ%_FwLpzG݊I3{@`c^7﹫OwpTR 7w4 R@A?9P6*=7 mkXtK"1=@7| kDG!A{pA9u{@gVnŹ{(kIBΧy@8=ø~쭰 @-j(ck/A d> 5hgCQ6.UyQ&UVN}硅rQbӹNMv3?XUu{E?8]¦}{eU#صnpN%ƼT(ic%v_|xHs*Qm'`@' V]6? 8Бf7`B`iUvr4.a5>T]cX0KE90J,_(I0*}+{1ްlN 嵲2 j6 d4<nm_\Go1s02k$[LF|eȬ?`AV-|{G'Xf >  Bu+B}f_ǦmG/UbNw?w{.3;vU5.o@fA}zɨL8s-5VBczy.=! $VEOzԴA7tQ 2gt!~k͞D䏶_Ƅ4To'x䍭ݪ-V5Lj[:rp"*ӏYՋ6U&{7u׌zQږ=wE$W`<@?ƣ/'eVs@.{X1-6x*2&5]۝u.nAĢ>?z!nn<[5\O H5Vb~E}Ԋּ+E0 ǟAkzΕB=W>߉cA #>u ڨo̸ִ\ ^qљ.}nOC؅sq.͇{2*Z%Nk U{8C92[B {W X&Z!BU>,QW(J(~ tLKp bgݷc5[0;>eIZru"J$>.8K7[k/h4i0MZgilY/z1ߥ5M ߼ ,zōAq]M,n}}nQ٬uĞW??$fVb4<υVI?XB>u31`Jezݍ"`J:wޕ>X+} Nzñ^y:?ʇ2 ·}.:CO[Ļ;w|jy|rYc+MZe+jŵ=1YZ`z=p&3ؼVA2[v؞hI!G:P/6X(3^җkm7S[{v>}5$~ӓ6DZ?쇻;+%jc }Qm4af mw`efcmiւ#{Noօ2[CyN#ui:0"vuU:]C81 ko٨uL{SGN/Q>j`T݉4N LuzΨRmc;dVEξ$U&V>}z./y|C>9ݎV}uc]LjC_T3r[DFJGRrkiS%2V0QF~7 TԹBbԛ_>8P_Um|PAY阷R.|bVAʿY7rkbbȈE:DjWJ^-Q3>[b,NV3$蜧4_csZ͸dh=ގǴf؊4?Z~G3k4pbPdpa}}]+1&IiDBQR]HDTe4al! FPnrIF0" [o ؞|-D?ŘF}@D:`QI˷_\/lvE{Ϸ+Vy]aw6!m+Q#)yB 0{vV:6QgH[%-b7ya :yZWƃqz.j.K4'>Ǩ;f3 Py;dD^iS_Õ"l-MYH)QTJ`z]mV}}J#/{h-~Q:'/|K~ܭ)~ė M?!B@/Xy{X_@A?4,:A/m]AoXyi#_*ʄv b5wX79ap`L+[:O5c-l_0嵢o:xݍ40~)݅WyK0*W J8wZ-6@9]vy{;e40F`Q, o XiFA-p.0anfzEz07S{A0!]1Ftb pF`AVe[2a_NwAOHs[mfm,ϡ!?e֮Frce mh(0nlmF~B7sKC+v ف`Ha+(<:Ӯjz@Z8ne?3:!^'Hi3U#L kH^FƱk#qB`?v&e7R,=&/j.Ȗ/A`*6b| |QvAc6P5/A] #oyuh'ElF,FkA5:iqa3FS1ޏ{$m4@>V&cN~.6kڦF(nmRS\ri`gvj듵g87hYWFxإ-N&~BGрfP/6!ƏrJ$)ԝ/6<3{g'ʥQO֝ f=-Cvqc mql0>ǹ R0~뫵YUNI#Zgg8W19feeŷ~Lkvfu%&/N@DžaA)X Xׂ9_`f%MBqUT܄ !A`Bpf,eDzoX  $!> !h8:EW'CznI _ɩqt΃t: Dp ~]@ uqfeQC}%հP6ѷL!O^X2JHϬһU턡݊~n4h.n.j3҇SsJXHЊvy{Qx R=Wvv b;;>rK*l55Ʉ>{)~XTkyC3mUO0U>HpZN &T4$ Qk6RuggcCI,d OhN̨r$G7">H = 9%Љ>Lo5ĸw6ﴼ|/QuzH,bma }ϛ.gKc)٘G[`ISʚ|m{ e>N􊘐k t:lXǬ3IZTBa:Hr FO1"PY' v1l0v謸X C0&@o J ‰b0 f3_(C:lj`UFU-ܨ +?Ca ?ZS=ٱCyqݦCqm(۱Kif5㚧ielfn4#o$kf! tUÖ7m`l8V8P D e9PlGPӱ/%cK'loeF{;\q-#@ vQzq 8fWcp|+z_S&*0a 3%0>XPEi\A@7݁Bgcsz"/dԝN1sFVk=&gX-F7DdE,H}H8&bC`+0>?+;`eoUif죌 }xRV0?ub;쎕+sTC {.iXgiQgڰc7ҏT{z3|KtTabl(I]Î#7"f>io-+i{NUTdK*$ZWjDBV~¡~-bm'CQJ_K~ǵ= c!TY b!ۗF#br΃-BX17|&s' ohPUn+mѱΡa4?6},P[WT췌cʁ|PWCQ]?jʔzNfuE<( 8W_H_ ?qy͡Nml@p"tx%F*jm@@1[T`@(?SGc?FSO\;^&z;@㵑gc}vDޕ)+fh{bvf3}=ƦjlM_pb1P8pFN>|>Hl?h@Cmtaj@cYE $ĤK.^tz2ǞSIB&c@`W'粽2K7 'j6 ɨ0"ﴎLAbDK%rfx #SrjS*ԓX<^0)}&Nn1iE]c b XP_A"AL% E v+=ČCym=]Қ6!1E!AtAoвWxL˫oTY՜f9y-g؛[sOEg /ޮS.xg:&Ci:{֖.AWʯ`~jWtD(k<}9!9FkvqctcOŐz `DY:yEW7xzoW/w؞d=_'ƕ_א^P߰cGI*QXZ'k:(jpw^o4%W6@gt(FZyctbQSy{R /_Z߭j;Sgcwrfsn3~p륶W>;~7xqP%Xɩi8D>X1>~Ă . ?}aM˟ҿ7t!V{kÎ%}1zTRSkY?}U_\ZO K*ntDl'mjU|_jۥj9%M5yk1RH{k@˃cIY R䇀[Wjyワn`I=ЗN|.6HǖmIAg(לY-@֢^I˨#-;ᙷ&-x_\tۋý f8BhJ[_ث6 넮̉ ϭËzSGti_;bq9hHIJؤFc@JO@,qq z~t^Ow{=2-q:AR`h.0B|[a~ErߣCfo ]o՟賦#h2%&X^}͢&qaGZ  B&7]+ЯۭX1x哃{dIoe~kH)oDY- W¶\-(Dѷ:O]r&g4i㯱|H@rVcݾXs:k壕ջc\^xv#Q <3(S+~ ZP' 񳫻[.A X)Ao-<꽑\bZ>&KKq|t7B ;x{{gA`.I0rfepF=oU4_п2B q3wum/|?Jp)үf?K>v^e68|tb֥[sU{7kE[=gUO5\>||Zsiuh@ Uܧ@|eE  A m*ĘiCHOЬG~,n6ܚD?OY/XALI,sD1+ou[~2*˙Vpb ˛wOh#{+kuk^kKzp=Ҹ,l319Mpĵ=4Z0o)׉|Z^-|EQek@J(D=qQۨ/)pfQcT|Q#;Z= 4!9~))i]SZLת"ЬwVW15ށz/xy J8 ~}"_p]\RyI_}bykyMHiḕ~qW/Bƺm^zryIϫ7cfʮuR/6oc;zy>ܧ;['?Z~;0丕.*״ ><\#al#}7Hyel\I{՜&'bbbȈE5:A4A0"jN5gY9\ƌ3) zV%/?Qѳ|!{$M[U}^# "=;5ϡo(ЂQO;G p,V 2ý\9l9jA A>t%*_0s }H]LH ש:xʁ4P']3c9ԶQvolCYĒ'ۡ~ :v1݉:F,􃭇oȱsqyM2+=Z2!P5:YFV:)SbZh_mg:{nׯ^c,Ӽ0Hh??s_HћyV0xo O!P}x,z+2[pe[ʺ}%ծ:c}~/VƕU"/XA%b*IP=xApA'Qn3D#{Dۿ[gF=OH%Аss U_R&#Ѓng8p.݁H9یXφhD,@18A\ryfiF6Hf 5`kP7Yr^}2퉠uWQjeu)#t`g}fac}XxP?VkE,+{>pMHq u^S]XӎxlsxALCbaT1 Cl `X @AT63/g8N_ Hɩs}ؼ&3m5h+OoҒ(HϾ$}ś2#pBZSHoLO3r筍t+ FbaX ;`u&>!XeG,W\trx0<:))thkc'<ўv! ('X N_83b!A &g:@*p=t. }kM}i3] fڅ` cΫPŪ\@ٰO%jϚ[ĕ̦*'8wv$- DpzqX;[=mZok-o,\/kQG~ =&uk{{{ǫ_Yz|PƵ=h}Nzj_Cv-qKwxMJ^}=zݓZ@=߶E<~:`D-F/]_ E~څ`PPѬZn7J/V}%io|'* "XG[3/˵c6 ƚOF(+0rQ~,b鹩Q ~ڎV烩'VƣOƢ7Fa[ $\v}e*GL2bQI1M [eZ +l?gT[}2ZK +alKb"bEc{ AtAP.)).6!EiS)yuu(;ې(BbQC1] n2 **OME}aN䗵N21m \vx,9bz L16(㮩MfWk&ʖ_ ptTfl_j ~xFl3Vf†@^5o72wˑgvqs ~GD4\/vLtGPb١7w-9>{2Q(h^o#%1d5BQ=kz CuZGzeޠˡFw^lzwѷJRα(nUk&clt7']S% (b^ر w'3Ɨ?Ox׉BW :#2%_n޻=ȏ]h 9[{7?p`牤&#vQX 7 :E#>;<*a[Y5ugc (+ Ab1ylћ;'X,5uxZW6v"P+hlfB&̂\ljcaUۨlyLRY}lrE=t[ ؝n@ FCc'ok7?kvJj>~48w4nctLnC qWqxx#Oz&R|miA,``<Kp{[҃`syp+g GiTd-"3pN4Մ'ў[f 6ʄZRyL0qýwtc 7Ts+Cǀy8C9Smp0ppr/7:Cuiʾh^PC-n:ti7tfC޵νrwL Vb& =Oz0~҆N8<~,f$x;'5=ٯ26l+ӯ?N}b\bK߁畷 hpl:pӑx'Yn5^c]k>?~v5ЎsfG}>˽55`촕/2H+fsH3.5^oVh?G1}>$1~%Nw>o&|~S\=I$PxUC@Oʮ;{š. X3cld6(ʝ1-rÕ}긿 `Vg)1K;?>$:v7R_ o1{kwXT::!Vfm-~VWU+x_E}{/^Z߹|Gt+"\+w]ӏk'dxŌDD[ eW_87"HЮIW&V (qWZ]R t9@F$7ʬѝעmQ-9%-"SJ,̻KOiNע j~iCoH#-F3k_g{T-k^_~ʅ6@9;D#bHz+|۫m%cۍUcyQXTKfːK *بMo:a0kٟsd8͎4@4ғ߁>{-T[ν2LkmV#A_% C0Qd /Դy }O9EBp(LjMƵzNX0~'}8g 45FNPurx_kB'r!xF[DF6+v=@I, ΉE~YfIR`"\&9*@u<^|yL[GxKj#%O{.?N H_O|HɬNX[,r D mJƓ/G_x<8!c Ѕ+ښ IIz1ú9.z̫Tb~-R,Ɗ!Sԓ+6ۋRqʬhs*'GJ,[uM8WMu-WxFVioq*T>GXh~R>V?;#b7]brv,xsVH pcfP,TVH;V.ӏm)3l>APN$W ڲ*WvqО3[C&swQXUS>Q#0Lvd<o"(㐌ZnN  @.>M>Ҽ$0~6I&Su\OBnOrJ,bCWp{e1.5SX$*?_hOGENq%SA?zl5V]vab3j*r?Uކ,Vw=k/jo;TN}}& Qs:b#7HbJ\dGEmU[q n'XhNIƒ'yS>hPdŖJl0*noeD',e dvoZf NV~bMT-~0Z` <ː;_ʙ6ëÊ/xٵ*c. (5Ѵ:|Ib,1^g K=sƧS1cZbFn-cr/sdnҩnr["wZ)/ a9 \%#I}v6 ˱D!95R~WbǂT|򉽍U\L`b1Fm Oh#Yv_zgжHa`i{\7)4O2Ov Cgmog\|r{mJ'/6uhN[s'k[,c W|vY,~|k}YFk'>'z8#ʆ ~8y-onAk4Pkf'k"OCn4ŗXDodNs;̿y4/>Yjq'u r>\p*]2?,ܲFK-ˎTZ2ww}T}`?xk⟊k;ٓ˯чS;NH:c?p0I˙d ;8slMZ2ZwOUGb&82X>VZqJ?eSMgZ-w?:[4x^*Nk݋=pxUe婩;}7u&s^=, 6%B&U @?r7dh("vP yI! .eem%jG} `v9nXG?'$vewJٿng676Pf%_~$S}>}ynz$F-mb\ӡOJ"r #5re,%r?rZ<"#./"QT#'6ܮ {%E }>1egW^[y$\t+睕Њ \/6%D'95RB\aC%eRﱊXqaIɹ.x`7t釲M}|[_xLr#!CCbBӼ$ pDV^ES,?yŢJ7sGIݱS2Zc DVXA2 ?(n䣗#[# #J+qWpXruc+bS#+,h.%uӏK\ P]@Lʬj7 2/1M_u{h|ma;;G]%.56eD|HVuTܝ~2y60V:д+5ZwӾ!C I,kL9͍/74hT2԰|WvG;p l4.KLAF̱/ycoHbaȐ!C&0dȐ!C&V\Ldb7dfP4302!1+"\341ۖx5 1R(_xS$gkN0v9g.k;SKW&hqLS~U{9ϨpWUgE_n .;0a?|kJkt Q 'i1F'J_Z\sct^}=6/`1vI{7(SQ:* ~oy]6!+?hvM*}qf(.isVmhTǎg|Nƫgk'/9s$@FX _']UʽS bf﹢`#Ǘ\ˮ&џ8}38bΡX?|@?Ep_6yo`o?ݾ;S}3Wwq_qmwW~=çkzv_ڦV䞬 ՠg~IJFAu'{˛).n  SԊWVힹ9V8P”Ǐ/Sxqܡ/BX+|~uK,|s>uyHּ;ϵɗ kN(4k_Co'驩Ꚇ ] {utg^n?E?gSu'>9z\tB3V.{fsG䪖X6)xXɯ =f h2>]ۅ|p߽4HߙꇍO7izNn"cn+YWu5Z@J>ʮ>O`>Q|E6/k4 ~~U1bϪ4Uul:cK;V>oNsOW*u0'~w6[)a*s^gynݠCNrwW+Nt}xdLA>i_VnX9?=G:o;w}L3*uyٗJ􏎞5O6ڹ%kKkuo]4b bu#5~J숤;&&evʵ7#O{zڞ>yس9BxX˕}bC"D!ڜ Ȑ1gXM 88P au켷I[_+M8J꼿X78{o(.X1H1!FH? اY# L@G"ưHakZv]#IڟF Dʼ%-2l%qG[v i[{_\.91)}QOw"uL|# џLxdOdI%ĘG7DNs| +nFQM]mN oVvhS80%Ǻ/W7 Bnv+l̲B̂ 6a[.>9Ws}c.rI]ߩ<=|4zb!c#Rb}9{OV47oTN2HǢʚ6֢#=jgM*K zĭH-dtt*q19?F]Z7|*}9+1B+j\DND"||dY8Dď$8PG~_lXʕzW(e{5R=2F/mBGلJ,CŁIcrPgfF^q ʮB$ g;P.oS[pR^F`#Hǩ]j8=z{8iC\0+ԗ'9唶vT i-Y;|Itk>Le[}RA;  8}<:-_$R] +CG$Y]2N*iwuʯnoG]5m`Fg&=3d)ًW'5nnik9gXdh~rzONXdd1vAJx2}ꉿ{;ezGXpK,dQͧ`|. Hrǧ ^e7IZsqn6@ m0oA+9DDIf"+a,ĸgr8}4Fk K#<4{)r=~K/Bk?,RM7vrkɊMu܂[r]*}l5焈c%WAVSdGTT̩.% wsB%.ؔA-sI,mP!Wހb8*$w"M,Lbsl,xAdr25n_vOX>V'9q5/8.[u@ЋMd<5DPX@D;%*vÊ!`){ qcU,IHGNv &l`[q*Wm)H;Uv_bAVX$*.M@;;٢FQK9ک֑ )E%ħ.35b DG"81 ,ܜա[Q7 DꎴSc< Dt#Ū9mN2cam'U[#&~F=Vr<&Gt'J̩<%N$RbዅZZY+jA_xo+oO-jU@\\ge̚$:*}w0ҏʽd<{N6;O&ce_OMC>;]=#kg77pU':ZxW/7c2N9qo]NKu}nOX>$2hr}8D/. ;+w_l Oauu0IH_n'lJJ-`^ץ7.RN篯2;W&x@=UYvDqgs"n*ѬFxoQ{KT5csSɋ =Nv#M.#щA__+kܻ)"j{2gڦA{}\_aKyU~cV\l;3j}MۻPASyeS+vXݶY.#!N~p$cnI\jξ߽n^:[vc/:Bi\ݏd4d4*G߈k,^f|:w}<-l ]~hi礙{{$Ol㵹{DÍ,2'S2HK]Gx˝|oc< Hc7[xtq)t\ I<&ev8K78UT8D̩|$柹hsVn2+HuI,t @I (;^9±XlhPܚ\8ڹ3:D(a2`֓6RbE!iA?\#([ms7dvK"[X| WX<P;z@*IA`r?p ͺZ$2DP''rP.CDi0o璉K}0D9PREIkeE >iFW!DDd$: ` ݍxDʜ9EjO+@γa^ T= іtBw+_ ;eMS<|81dPf%7;Aݟ"yF#ŏoqؑssDn~?Ray2jJnTYDS7뙟ɘSuIPTh'{$ }>q_>rnn9cX9cϻ{{«$NZz\eV:FJO줌{![\S e$7q1aZ]"+hqq {uR|չ=OWӵȉ6Q~~WَTto'6}Yp9;d77B6{S:Obѹ}|dI!Q SNJ䐨x%sz$3yHN#^>;~Ϭl/XAc퇭;.՘t&ٲqՆVmt~\Xbm{KRF{M?W'}U\i C ] 7`g514QhB|:enM-l Yvw(o:tU?w3X2dJ,K[F?& b O(e\v7q䖵w+mrmht,3 7b?nxEX2d-X2dȐ!C7s\LXbaeD^C#Op[yDOXS wb1Qf$|?k}@m2__TޔoM=:v8: ܯ]efʒΉ6Go9g/:|2eë/3dM, 4LSU`z^ 8?svgꅺ|OW] h'קLoqvn$ލ&o%z}pUq0:| z{KeHk_x}ʷ([e>Md/ޭ`<]3?}>u'W-0m%^0W7*l*8SG/zގc%v٥?of=}H㊛_Ƿ!#g .z\tS֟n#疷*/䑑 ϸ8Ik q"w*,~2[ Vpݓ^>Xt_~77tq{yy}?Wv;_ cb ~}럞rGQ*77ӛWyoGI` ޵Go[G@|}~JD`xuMl0Uu:5iWϬ$Дz~+|s' %oW,ۙ"u}Rq7IZv}SB䤧hs1P^|ugZij tɒ wGvba}b!6+ieCRP {d0=bPvþmړ|IxzZM".lAS3?}<xbCNKVR;̆.Wvڻ _bIɱm59W'??}u>OYvcRwI9?̗r{TTSUHVկTYD۳֜jwJ,O£Sbk| @Gؖe ݢWn<8lƩ],mq %o:zήoX P@35%CJ~zڞ*-l+|޲]h% =`#wXΊq^چ# 2֕{rO4?>iXIq#O`@@#O HȲz< /ZC9nmdaN^0SN}uÕ{_xOx˰@OvӷdOqM׬ܫ``sV+:z۰/*B&~wP-)M/ B 8H_5V62)y MT',c'ϱA,("ڮ~䃕k9g~to96s?mUz{Ʊ_-q)\\ϩoSlm~I󊭑0{_A-V^>dnK-mtl)]'_/ Lt+ޤYHS㞐:_wE=cv'3~*(0G _u~UY SI80̐XV~Y1=YIDkr`q]%;[8GJ!NvH* %8@V<}lq`$Αe+ hq#ί][Ԁf${u.ՁY01Y%2Nϯ{f Rc;o `p2@?pJN+2c Sx˱ƇL\?1NuT,t]!&e/|0~U`F]VhCIO IΖ;%{/$I&Ї4m9,]K\R@ pHpQxfoUAU, 0TP ȣcVSU2K"hEӓZ/>-O `CKv щ6B_b\ (D}f/%uUeB+HR7HLvǁ"ͯ{HX2}X#P:~94DBYRIRE,FDҟSb&o5w貈6S\hn\6X sX2t$7ŦCE9u8YƦ>l4}e}V+D:eyZ;N`<;̬%ЇVpԴq &?~b TuK,pAZڠj ;/ɩzΜPK>Y`zvv %uK`C6pıȍ6i) HR|m>ׂ`ɊqI:a5GvYBnvJ,į"vK,OH-[Pt9R-WY6"a'<Q}_K3=x'I*~]mvE'?ǑvU+@.¿_fqM,@9]LK@):3in1ӖsMJߖjzM7|\㔜\W?HmFK$=GӍxm8?1Z@SG%|ah~8܈_ b_W Yևk2[Scs$PmRWc Cn!CnbUwygzy3`_M %WGl_-mK-nD>RH*HHUU\QY|g'nhi{E삲͵7|f^1=y:7t#I, 2dh @UaOϮсZ⡇f-ܗQ]@w,&Э%;/gW4,|IV_}? OrvH&oؓџZd^˫>izH.쏽)` ~W .Z M dDguim.Iko/9Ё_:6*bxٮFiw/'ׄr(u-z)7nħ^S챿Aq9fZ[h&]n0=K[h/'7+vo?*\]ʼe &W_tW 8^ T ^R/'%/&2XRPO8&gy+ĘTOX6 ~77$7d&V 24A(" qZ[.W6 r*rO+Aˏz.ƺzdŀ"gw!R?E% %Z闕| ?>eWnyX `4ifr玴 kky]ީFZ#I }%[~wdKجKħϜ!`_4 g,* 2dhPXDmof$/9 +!a\E޺,"$3?z!+үr}:lWَvZef9#rxzڞ.lOL{GH ?o&d}u}RJ_Gڑ84@3wÙ&~$Pf;;RbXT<_sF8Fg_k'$Ȋ:dwIONHJפwtGWT_wz>/6~ݐI, 2dh${HD5\pړ^Qց ^TK?n+})ȑ:x$*Luܪi_ ɖ򛱲ʜWm]cgS@+mS+vI^1ZXY0nM-ǯ\@[ґ/V!.@,:d' YȪv4Pf;+ MDߑ Sv,Kk` vw!Wv'a@v$&slߩj;IOnalewo_TA5w,$^1V !C&Hb/:}1}ƚ\" wL?:uK,b-xm|S{d+)84 _ ƛX+ɴCȊq] tGh7%0'_=lJ/ 5`-mr$,] 0 m5B'ԓkE/~CM4(&3{&^l,Q}ǓX K#mcPMΘ쾭I GbSn9â߿uCVbx!C& vLm۔uX<[1cIuɛfU*WD+{C?xt~ԗ߅5=UOѥYgJ%׋}S>XQXk?xO26':~6X|і/uhG;û*\;f|*c>t֛9`0h;;Nc55ɗTasT^c gztn>ޠTHzǧLvtbj[Rh| N:mYcT]e&0dȐqJ,2_%AVK#XѩԺ+ˍ Ћw,$I e0]ga>=>x20x/s]4*AOn=bOhDؽ!C7ebQ$3dȐ B$F^ 2d& 24Q(̐!C q$ 2d C 2d&J,V 24A(6O"SYVx 5C k*&4رѵ!Cń%Ue 24Q(b}M[yo$ێ?][^a&T=s20T;5r9*]~o{M)gjF3X0VJ'.6B|ƳP>3.7U/q!Qc~w{n'o|a(![}DgOd߼|iGl2-GJ|#>Gۿ&0dȐX|`f&H_0hY]zEu|Oqϼ5;+O/} %}9_Mj߳`t'e\톤`$ UPY|@ُXg.c-!;Gnn>`]IyUˬ:}Mf# pA6@9ڮdV]N|:7t] @z ѣc}W} V 7c\;$b,XȰS:}4Æ J8Və–*D]ڦh2wv4LN;lQ{o_H u;zpKw4&GVaK\G/9x^7'RbΉ=*ʘtgF(뜝$o;TnĢ:pԐ!C& E e5VApqjK_?_Zܖ@{K7wﳅ6غ =2<5n9߰xY"Dg֚LH˞Z+sSZi~'/;t>|ڪS.WPǷvU6 U}׶-˘WͫXQ;s+ }ezvu ;jはw,7*@dE?>.-~, Vk!Y'Ϧ~J! /e̴헫{פYې7272b|+tjzuMv.SzfUN||hG_xeZ='F؅IYS~cWXl_Ȼ;:I8Y"Ƃ1W~+$ן 2.>'vfpK91OЭPd>Gwhƶԭ$EczԫNWέ'9Ė.6T[6a"w{#NY~:}3~xgo 0v+CzJSy^tO[Ƨstyv_][1q戋&0dȐqH,V- XAM\CZ~7A8R?6T(m\ n%ϊ A~ / Ra )dI@GBC>Ɛom # iW <'^hZvi WA: ]*d{SJIrB'=rN7V;K ڜP~x̐K- 9%g S'1 Ӭp\2~{>mSM'-Ď{H04Dj"ƧQkRZ< !C&nb63 dX9uV2`A ىE~G үe~$nzՕwy70BW#rXK=`Tp&HzfJzJ1NĂq G&;QSe{مaXGڑ9&|$yrJ,T&n6HBrUϗ\S䈜 IUKɢ<#H>_%2Ȏ9>v%uECH6JȄk2uG$>tJ&nMĢ2dxXڛ>@,h:XU23kB+@^DwMnrW~iN 8`K?-8^r*/vT, ;s9 *o)} Rdwt9̴@{S[bҪ^(zZ8^ZEkXv5f˻mh{ZOHMu?)  -жpiuT]z=OU>ZlJe%P7l'JpD!rNtlLiΡVьordpN+8GA <0>MMsߑi>fDbFj 0:ȍ>ÜDN$1hHNs=@'ǻ^{U}`$%->$Ti4>uCR[n"xĐ!C& ŕXޞUqwda)l`r+mEWJ7.$_dUݞV- l:R⍥Xt97wW7v3Vmq.(O:XhR%s% Ηv& 얕Zu]zņ*7 NʾhIWPWJߺo}*5~{,;a?teWX)T3lCYv,!:v1PEONm$@>>0 ξB#zȭ)SESI=dM,>ce:k2$(q1?tkE"ƂhW6txӢz| k{[V"P͵V7nOYY{[^Uw2˞޲H@U>~šK l aYR=׌{vgϕ\nH_Ns}wã΁3v/2U'8e\܃\G2k<ș?Qħ*A]zG,xĭ#.!C!~G9@G=J=b%nlp=!0_},)is/vt  e<\PR/ UQ]! JOǎ\M=hW))ؒL|_@&|CY%m_تtYDSO,Șswٕp6uXDmi6wJFB7;],u̽W %p' Arb\VIbk{Cc?jU:X}\_'ϧʆ9΋}Ƨۅ=)}ċPħX`o_|GgW{"ɐI, 2dJ, V=@ :GBSu}HcAW&n"pؐ!C& ۊlXϪ'4 \OCXTX2dDx #/C7 |s){|e]eF !CLbaȐ!C ݂E!C M3023dȐ!C}\4!C !C 2!C !C @Eyj!C M'02dȐ!C&.&2h:5dȐ Bq%F^ 2dEX2dȐI, 2dȐ!X2dȐI, 2dȐ X2dD8 #3C 2tń%eV 24Q("|,I >/mukVqGS9=EF 2dV&0dȐqH,.U|CJ?T𽇖\yzzr Vw3Em%F 2d$ W 2dhP!C I, 2d$ 2dȐI, 2d$ 2dЄJ,>7dȐB%F^ 2dEX2d8&ySSHZ'סn.s*sxr_wv+o`oؙI,LbaȐ!XēTBR' znmo77x:o,o~g;H2(_>Zo/piu"sRs |hڗYWwκ_o}t,]#ip·,s әюvߟMT>uBXC${ʲ #h j ތڊ񐩛}*}N=ζn,5>fѶ^LbaȐ!C&piՕ)T>YSA*ϞZճdZ<ζWlKOwθ5j$V>o.: Վ'k+@k(C6#7Lb\Wͯa9Wؓ_6EʣفhCrhyu f!#m>8R/@GMonmbH6yYzä59݇c?sK5$V٢ƜXʢSӆ'LbaȐ!C&oP56S[(guZ߭0AܓX }dof_h{ ܒ$N$--iv5cD-ޖ?z|i}o=^rC+ .ĂM]!۲+Sʎr XĽn P~Ϭ9WY[mbsIe7Be~b#ʮ)D;+cQA2 Nb*#uey+#}[}-d+$8,}% UO_{Ё3aGwDʘ] Χ(ʎRd}b/= ($h/{foѥ}˅])KXg`+G]U$U9OLbaȐ!C&LQG1@9$|VpLJϱ$|$gzJ?uI_1}MfY T9N `ן>e8 H‰ϟ^ճ+y8X$=$ G5 n ԕ'"5xoizG"hxnm7 9*̌} В#C0,y|yw!GƬ8q D 4r4#YYoo<\VXT{NKH]/yw䉌#7`(*9]#0\+p p8>E_]K }"[!Cfzaw=%::ѿ;;Ψ:%@?$$sJvHXGn&Ė.dK!1|dƼQwRs Dzю=.sv~gTA[UT;\#Qf#X2dȐI,Rp,5G`X@;1`rVF Ь*LeŜ9 Y}6I<0cXՕE9VPU`Lux3֞W 1 M% 1uUT~k1& }DE9*Gh}a&^,pr{XBEiB=>Htl ~!P GI&INSKHPBgsF:w,CL]y#mp$&lLbaȐ!CUbAu Bu'jȪ7 YqdLҒ> g}`yvC|X ArD]Ăq=1g93Ʉ_VG9%϶Nj[XPd7?IXyׁWĂx2X: xsRR ȱǬ H yPQ9^ߍhx6ITv؎ (\dRxX" $%꽣 IV&~3m$ĐI, 2d$v,To-@gY-&:8D](8*kцXпg8BڂA8~K72;.DڱM8쒬L.W?y6QyKXGY@qLK_ jojǂ;y[zhB{`5:f`4X=n$ 2t?cX=H@ UJs $@4`6V c|<*G%KJK@ P-G'x}{wc*Bg^9ORʪXfly-'Xџ\Ssc#SM,xCHB*f < M@$7VI"O=#7cVoDMz5pwE_*mqV,N@}@|$H$[ ILX["( !X2dЄJ,2}9[_6d(RRB6. 7d C 'Z|PnWF5ϹkG$UoЭD<נ?wtz,w# 2!C d!C 2d X 2d+usڹe48qs"HsX&Ǚ7UѱxEEǫ0ycxFN,2Կ>8.o5!z^sz3獒341C[W'H: N73>q)IWG{EnŽ*+zo7oX!C$ղZJ>l%_F~>?`-`N^J@ӝ3 hdxsOly5x=L8xm|g!'6Ȋ߼w`,OM9{Nخr{Nu\sT=۷(b%kn7@fe%&X.xUt,;xBϗ+^[ڼ畍n5vX2dȐI,$@epF'&Pj[!p Im,]'Fu-W'%h8`L^K;$-7P( .^{QЩ+OkݭG/)XVg{s7wn9'wcC{Kk&eRY^>kR;#Q^.8 h&; ;U[&"+%cV^iL]^Ա?`eld} {Ͳ×~>1uo$ņI$FQ/%U>No-["#P \\ʎmw>(*6HIN+;?z|iCE 7U]8|!C&HbՏlqR9&G$ Azqu3zJ4i. >4++vZ͗B5/@(A0K; UCم/٭c4cKG#.  L|I8_#;v#{d |Ё|]zq  ~Hn^+I clog]:V;GF$2 L tsە9%^ޙCN_0(;\I-6ݒ0/Y#,kzl>,;,}8A!kd|ț9!_~J<ߵd;; ١d~pA:_yd}hx" t) :Cc!t*h,&NK՗[*bd.UqvOiDoNe,I WX#s8}q]tX 1!C MĂc[@SvrdB`4Ay$jtXd5 oNGsnZ[׿ ^:EAzkG_:Ls$ ,m83_xOŊ+Bhs UjYX5 MuSX%IyAԓ]h`jr*(b"3(fqe+S)-2Qu# hy(n:&>ZM@CI]v)ʨj3d~E7sK,p@>+dSb~PSVeqD]Р/Hh5bs2"K{sz@/'?٪sE!HIjю]-dG8-b$"X2dMXՀeViY]HM9 Q0YZ|wj7Aj#Ps\!jk+Ya\:~p% xi6@#n!+ xړ$pP ;,\Vgþ"/ѲZ. ?V3l;߷;wwfvvvvƞqxI-gYlY9VrB $@$I3MD7t7s )LQtCyUuv9ުgځb{ۚPR̞g#+aՐh<wm9} 3X ',\}@8b ?LPp $:A/*mEV_zg_~}V=kHX^}6bV=.\nMnbSd8f3=U>"bmMB"揰105X#l`E-!A+z(>?9xŘ)e[A ,F*6LȐ2xF۔ bE)d2x8_hq@U_>W^\]_%7>#m/~F a,h.Þ}J(/q /, RV ؆&K|<NX盽HXB=cOXp֗m5na3 ͸:fq)f<`3fM7}{u8ٌ*6 `| a)x} ,&>ԉ>JVu vA\7[@?㆏>Aqk\O x`p[D$7{Lg 0\?5L`&E_1[m|y=c(30Ŷ` 0‚}[3Xy91Ɖ/ӉU Ɲ_gƖM(xEoϕX=xPhV`bk#YI%AX>2cY&aA !*,ػӱ &K·`-c?P,`KIoг}nLϬ9damQ,%B$-xH  2x.چ DŽ -Nnܤ#f[6){@l[q DPGx|-&B!x]uIx,~l`Ϥmfo m%)s\PBكl{~$x.~.+?G@ V8p3\?mK;3y'0H}1^!_{П`ەoo+=s$> eV,anb2*ZM7 n_-,>9wƃЋk#h00M4~?T,nE^0ʳ7 kCwaFZ ly~`h&>7=qo< 7A{7kl'◱لp,/Ym&nO" @$a( X?2Y6BM5r7jM'BM‡¤Ψ/xXqO, aA HX`"az4$s@IbPcKÄ Z/l D}IX  @ +@/P#IX @ HX @ HX @ HXЍ@ (}$,@ $,@ $,@ $,J  @E@‚@ @‚@ @‚@ $,}@ H‚@ HX@‚@ HX@‚@ HX@‚@/P#IX @ HX @ HX @ HX J@" @ aA  @ aA  @ aA  @@ t_$aA $,@ aA $,@^‚0ył@x@ ǜ\M'ysg ]45R\ѡ9 %J(=gr܃sJ(QҢ"˃%J(~?D%J!/*;{xDg(QD)EK$.(QD)Dg(QD)EEihtRD" qA%J;Q ₄%JHTL%J(x₄%JHTL%J(Mkލ?IXD(ݝc~SDIW]cW.,|>_olllowwT.RJpCzNE%J(𘄟Ta!z_L1cư(DR?SD%J?rq!X=|0ػwoozz|zaW:;;{:4~ث+..ݳg@@xxxbw|}JF!aA%(QDn\!,xB.{ xR2/ ˖-]r,XЛ8D\v'mhhvٳ?яz% d߾}C򥥥Λ7oP .",Rۗ.]ګT* J(QPoiimkk@A$A|dgg޿؊5Dٳ{Z-|9q¶&qؾ>]ln7/@jjj&DX "@4%J(Q4$$䑑cVUA <wی^{^2jaa4-Hϯ@0G 6mݺu֣O?@9V("?JgLI!KR‚%c+Vۙei{{~ǂ>?JOX\n@u=RHH  1 J ,!AXJSVXZ"bL‚Q 'w&c) aA$N@ BtD‚8JHX J$,HXPQuBHX GR v@u=%"?JB]X86aJW/;]Өu_o؉.3aAXJS(Q qaaS EMLL{kĮƹ?cxFUom]nwP RDĘGR 0 679Ι-nO_/3*>;}%㟟[ ǒ;goTjuZc:/{خzmǻ$uZT`yre}TP_Ymsog{:enݗϛ[z mBMF7.u1A-:Z N}InXݠm~{,%JD)~( <"a}1Bba#qv|/6y73;ʔ|ۏ'wjvf]h hT}@;&]v Dh3γ_% f-9ѽhe>⭗IXPD1ŏG,,v0PX򉟱^]V<ޏ;Ӆڧ58O/-zgy!Р4 Ի2%mq^D_+hu jN&rJ>G91`/ʿo֪=W;oW]WƉ!ԋ)Ps~{,%JD)~(q7m”BaE-U8u xT&oxT*p,&^l a͟xY?EO?%lc6'g"AX|Ź Tߧ>Kc%J!.,,60PPpƯ x<5R6(~"Ho%eH|F+$7zD%:46OVXV*iY)m3fy6r6"jIy}F{ ꝵ$ރ:\mI>AXJS(Q }a&L-7xbΟ;˯0`%A{'qRa=.?Go/:zN;'F<_fN*h{Cp'B8Bmu !lCh/'~ܿ_ـ }b5kq8XжvbG~{,%JD)~( L2J< gÕ}ΦkN-lUolA9VGbzq;#yI}iZuc@aՔ! Q"Q{~= ^q>&:? ACN‚%JD)~(=baaz] Ri.7]r{` `xѴ:d3c)Q"bLD@ DH%.,L@ BtD1ŏ@u=%"?JHX JPQB(1QD‚@ HXPD$ŏ46@u=%"?JB\X^+@ :Kc%J$,%JDB(Q(MuaA Oc)QzR\"AD‚@ BWXgE*̆c19v6~+ޢ1xf8ع;=Mǐ+M C] |ur៞]՛Wv8<*GZx &ڋ#ƜӪ--zϐ<_#7N,GٮR <,7u!ް弁خڛ%M'gu1mOD\xoUl󟿾1G#>XqƇ>N,QH1^X/xC:8&WNFC i",4FoHHɗEGs 9ɓGi5U^7/' "SuJ;f/(np#n+WΒ6V[~Dgv|omLq0]'5=I![ Op3.mH=+,q>w؊snXhxԊ:`GZA_?}ݠzzu唪wYm/#^:n8kioUdmE,|Aacܢj4ePVh͗==yw1?~-]m,JZRuw~\ Y;[2b㹫y]id4vQB $,B a!<9e@2AAA6 ,=cd{u"o.8(_".߆PdΚh/pE=V&,#څ ?XeD5nP'Aܭ}dvݝ73(ST*NH1cXLT/P&aA‚@xa\z2@ 9{߿nW"ţH(^Ukިt{ r_\-j,_X',G ][7~rHͶVF;p>Pn⴯R;Gy/\me(m\Ϩ6#?V:pm9y/OjpMX-ℏEmjsgϟ?7k#9 jWduk#ƌG;B;Erь /^G '> -Tku5׻:׃e/~8ߣmBʝfhooRZE?L; @͡Egthru۟ϭS+:ˋ*젱@ a1¢Վ?^Эһ>a:'$fG܃72gX"D b d6=a]؆Sdѱs#ɐQ4* h{t&O_qڋsHHro]Uf;;l6*1>/{3/_DB R6qnZ 7l:4I~\N4Q?on:x!v=Zr8W*y,5R̘o,8]=GWsBN~͘!< aA L`%K= Li,fZxCӻ!F?wNJCDK0bou~^2r%=K]_rw a!􇿉W d O;J>K* VSntWE^vlvÑێZUmkNy^͗nz*M[s5tMZv;ʈmJH6ms6x>ObB|U1o*Z#R bm0'am4}‚1;8V n4;Yjm}MquaxOX? ^vjEו-ӷ"~P`ځ=_=k\B>6FЦo6ǹ?C+X`-aja ajptŠk /px;K J:EZaE_ޝ]CBrYg.I?R>\ ) ə՝W 0C2aqX:`3£Ĵf$4̂I߽OȬfwTmkNWx=#/]x iYA'n+Pџ5ZӫFq܊V+h[q\l[ ԭ^ۋ#}}3U&D|'|ƫ ',1A.X/UĥRӊɹR;bxbEJͬK뚬ZԬΕ{; س"WcLxfVo6Ǻ;~%<>R"E Lt/NX +Gą2:p0_XNB^vƑtźA>QxLeT윰3=bY/=#ǟ?D% d£ hPٴÔyr;:򮏸Wr~FAvE G\nځz-Πb 0J a1¢@,p¢^;_헻[tRYǥE5 cy_gNVu`9v[ٍg+;TK;T3(/',xs- ¢Dm~N£t_ 8rS%5i']2{φws $,1 ׾>B0@Oy_7fQ'3?HL`:oU"-n`6P<,ۭiq`*1@Cw=?owX xa6xgݓ2˚u٦\jVdRj͏{SKX8 0I&,hj6w8`zKgۅzm6owexl>P}^4Zbjgyr掞{a]o2(ߙNaq,~#&FX蹛6@ 8}mB(#mK[P Fg:b` ΀yPmK >5@ :q7@ LLaT aA !.,!ԑVv  0&$0}0}B5B@ HXPBcJ +w!tM @ BSMXx 0}0]Rߦ P6FC i",:@JbAUL5a! I$W6t Ch{LG#.n{wTak։3<:>ܩ>9:ձ+c'XkTNtcc7 K@ 9#,d]?t_hh.6ein=g9}a!u̹rmmK>7{e?ehz"ոrwa]bQLoa+Ezƨt4q=a|D;Z`}NU!De,/ar@‚@ %{s7쑐RVpۋN0RRAJCbD/x`+}99R_E"]Jh|&䋽W"x۩kZf/BH~\̟uM _P&/1Vп)%,,6@ hB:s*9uwLy}?c**qOxir0ҕ)S˵^떰92lD|f-=D٨y*T{;WŒ,7ej|ceB|N+D&X)1*r*tJ"ܭnjRqUVoʠ/7f̉K ' ȃ8XX)殏\rʕ]S+.\MJ3s6Kl &&,@>.B5M 5F9N]>w\Zoʑɹ`JC)Z%uH-W:戫R/`C&ŪZ۶УNNXtr}m$3dȒ*Z~掎gNfڈOSLVVBjUFľ&ޗ3*q׾8l;;꾒RFB{Iԩ݃e>c8uD`>t4ŀsOkWTV+k.fqPEۯZJMko3#le$,@b C)Yb\#i̫7&o:==&v6K5 WNV:G(,܍?_[,3|Ŋb[A֟|wgcKjK1r#㻽7L|[Nrc8+GΒ|d"I,~Xdx\62X3kYm|3>7Z{WeG?,bA a|) @ hk (zk{;Ge3Dߨl,ĨI@SHHWI59Brw pnT4ש< Y:9'27Tp[Mx}Kf/߫U32|;G Gƥ5&Yĥ<-.ny QgYeZ97kX+$ng4=:;N/mskAU)6)of˛Ұ|Y|҉sbk[H0WI퍈ͥ;jv-@ڠÏ߅=_5fOL5az\i-N♲=1##c W?n*κfo%:[Q{7ϕerSr#jqJGbQks-_ k[;PF Rhxia7F9~O^+m9(W}7rJG;6!]Ի_y.ir5dkyr~dOe!?_"9w}=g)ֱ}l:R]`i{}=kG*>)ELn;΋;of,ߝhby&)Em}|<qDLU'-SBp`$L L-aan4# LyjfXv2}]vvOD\&˿۔zOv3Q13rBg;7*Sh٫>::^n[?)|#< a1XX`ł `LW[ OI~~гhG9aEd@^AY^j@+js8{FJL,q(`1Va\(z} ^p{1V"&}d[~n_qq<d\ <f_$1^5@?hUo_1HX3 &a1eH_2$ퟞ][UuROYM{O>ωV7 %з +`ן$vVwb3 Eaջ\{",Fgm:t m[hQp[}ucaP!חIm ^Spԏ^Q3hW MׇNk_s=i1u2i4{gL?p[ZW:ҵT ɸ\LCzN@ھl:_/Cv,tI^q6O y^{vf6{Z@|cKϽ:S灝:kn?!?tovv䛷B>o|v  aA $,BBX$ܫz^]}Pϯ Oloٝ o P ﶁlL'{A^ *7%|y]1 H9|1H1ț0Ս:q\ՠ+Ty$jޞ{: Ă'#_ʓK7 6t<5+SiNE,Fj+{HWI} tV< ֟:ۻãڔͶ p‚oW6CޣyѳĽ6&>P6c k;pM!#?ۆz1y8`!k%19|݈aN 6tA&AXh|j18i53仳j͡WNL44?}eC'@ZZ03J=M-VGU`C͵ngպm ]X騕WNq۰u+V^q&Ky8TyOX9 e~3ht΁ZZ5&}#W[cE>7{9;fh_X *8ۃҾxWؗ}k'5lE[/U\(W+7?ӝ +9g_! "] | .s4.¢aBcZ ;ALk5.FFqs;4~l^w HC 5@Dg; HX /,Ad&9r!MV{BI|r/'xi',&#h_X ҋ5 )JTk86^mn;y_xhq$,n|-.^~a|G-6Ny-S&3DѴN"L_?~W(\5xn!',F[FNP. K4LTGun"`ӡ[loc@{U?guOD̂idD?2 ]۬w~k+gO8|~",@fF@R?!Hl)E-8KU5$}z#(W>cMhA81ׅ憵w euo/=m[3/b W/qĬ#7 G.vqD d䯖#d 1XAxU"_?l\Ⱦ҈ hyK0`bL0a!x )?]s! G 61QQ,iיPq@ a1DXFBR#X-'[@Ʋ k2dnj8_4y.&Ȑ#~ iٚ`@]ț؈yզ=gr(7 W}Z@ jsUv& ]6~/GrF7نkYaw)) e;`qcϹj.Nw O]/Wpq<(U}߽z-}юz Awߌ2%OV_0-1sp 60ޛ:vn֏-=}i#/ޮ!,~]CLv-=yXjf'l£TllYkz+Z'OyX@e%X_}a fʤhp^O%gm&mĘFNfq6YD fyx~A|Ab'}nF3=Pis zِ/uWSտ-f!8Lʑc0 [#3s7%yr_n3]kDGRZْ@U]^@ħ56(C1Ke0¶K\SϢ\U \Ao#+Ǒ*qk~̮}&[%ZUmF%a[v/nS ^ޭ,opqߒ`G|gx2,6O~ӃA+Gɑf0B,XWA컰~cׯq\ipb 9,k*G[Z.6 ߯66olm?P=x?u\K_q|)ް` 8%_ QO\4a 3vcBO<_a;L =ؘ6caA‚@ $,B\XԂ ̾xG~vJՇSH , pdXp_ʓ\ġ| GB.ݭ∴1GfEk #>[Oo@"NXNgsT 7O`;lD J9@NvaMeWm0b]LZ?f1E79,i3G䮡^OeX 'fj΢~_5sjlP vH.N0_/a>FYX\YeT$X9WJ ɅW_ pB$,ي'91G 1&殏1"EvП;q׷c+#XDHL{syA}QR58F_,cVXgKȉc-ؘN`Xjo0Rd0}0EH%'qlJC,*,W CWf{՘%?k}Yu]>_ rUxOl6Ikk'7׊aŪw45Ñ4?M`W}gUKJ8}'8#@}dVgu Y=컝\ _nl#zV|D3F8()po.8\6QSe^w'ݢZ؄LqdO*CuJ+&s€r<'D[ :/4CgnT (hb0v~ CZհ i= _r6>qEn#[Ax=l@;R+>9kw3)yY=|X!ٚ#G{(:sJ=1I~?{g֊3S! v 1굎ZMu+9zrJrk%JJոu _O t|[F[KáJm_dMF{uz\g>/YtjgF iY_{X+k\_m{zKB+tAW|zKm]:&8BYv&RZ?kC/,go.:e ‚;NgI]8.ր>AZr*lsZ zw1{A2-bXwr/X߰Cq[q {T!.dd> ~7sU,V_f 7âPbu8d6 ☠W>?y\&v8H.h: ,`'?jsx\ܟχx,q>e4mXbG{4^"1]r=XH[m28 -zw.ݳ>w,KktT؃q 3ja{D i.,M{(9+r%*e9 ca"P*uVq$6[f8_X}%Pp># rh/=6{핣#T0Z:fM ; gUH a!Rcg}@3 * ҿ;56:1SL+y$΋Ņbǀwx}]3Dvp%&_¿1Y\o ̆: `l;}ÅvIv~"a>eu-=Љ|p"P\q~ŮMGn{Aqm5;X\+Xqz0- O(: }wgm-qV,lk:ē* ZXBȁ/Hs@aQ0gHV,^)s.UE2[q\b4e Ba")l>& 2 WC e ᵝR_mNڇ Ϋït$&'{▇6nG!V=X;>#3HX I9~H+pRvS5H/0#~f~\++<Gyyc)KGqduP0qe l> #$,&AXXǫζx/"ݨ *,@Po9T35!$J5)@>y.$ӣݯ۰%~o,\ r 0X.ڑc;30[2B"͸CY_~1m 8jy#=|L@?Yȑ>F+w԰sKvЈI*m+b1|b$&⁞9|c!^bb\CY}裮nh +bu4 AVK1J`Ko68[X`% 9gԉ!W.11 _&V=| [Yu616؂' P (l+M3ba VX^0k1G~",cϹ\fڱ 큔>7'!qd+LjPXm me۠X}‡jlX}YaXzm; "Sb2EB_N&X[l+0fօ`+5ϕ 7۞DV ?#nYgێ °!{񊇻!U4c[H;x-J""38$&lşi``cIXVX @  HX &!BrH4fP\v V D30҂c̬{ [S[1ae؃m1﯌6|F` aKL TW=ae3aKAdaa1(@e+ȋYtd OmP0>?Q 19$, [~8[oՂ m5#q& }lE^ X¸c} gX"?mK;V2È:VJ*П? &^+-O cx 6>Ӄ`1:ևIX #@ HX &!BRK vl?>fr 3ۜ@Ax?#8b]a[t +g 0,1b2bv٧U4 ۪YqBۗX'W(,Pg@BMg"X㏇Q&P#a{{N6dK|<r3 `*V9>[cʥ `xhŰo(JPba`[`7)AT_/n2Ϟ) hGb%A1g+o|~*&+L `B`m(xa1 ċ#ͭ.n y郕۪eFh*VZ-}7ѓ/A-\[Ɵ۟ wºP~<Ɠqy:y~Gt| RWӳzk&Saw69\o-<ޞ^m#I x vo@DllS X + Fl {f[:@֌&h>Ǭ2l߫/iap+ 'k. vp{-NFċV\զZ[uGASqCKlort.CZng2~)ױ ~a!Hh*GdHL^nD A 1PQ7snadN 5=E 5Z9 w{~<œ>?z{qSm uwGd !/7_XpB\".-?Ʈ~e)Ɗ~٥JsBJ|UcG*OW? b =/~ё[6'ܭk >t9s{s3HX R֚G zh_0iQ nuZxg|2 U[ vjI Ѱ'*':`H7uqd6(5Fz )q^Oum),?dחY{K@tYUofYPZ`àFkdXc .Wiݞkn/#_I,5, A[zM1eM&Ģgｿ8δѿ`~]׻ٲ%K,KD@Q%R"EIs$I @3&<`&LB3HTLwWx߷SUݭtڟ9r1␒'4nŭQd xLt0aŌ:k\H-)^!I'ȯP _]E 2DXDc7H2:>[%ͤNa~]εZVo D$: 39W фEJ.ăPX@D,𻯟xMP }DZ4Q{W6hd+&km jЂe2B3XXcND GzL'x3b怐hQ\שk8.&,3dDtĜŽo~}&Ha+fj0@hnqYM'8aQ\c1{ŋ&40J+jO z!R ; b 37t1sءoń|8PC!P200aT 7w\Q3XRl1ҵj:\Ŝ뫔:SNB" >S}H:5\-92l\~Re#&Gc7~]!FiO wD?~hy0+`q!Q'@<ξr 8rUsGt1f JY/^H N|>D(nWⅅ F^MȖxڹpHP~:F$j-đ:?F|<7B3?И`_g`-`‚ )luՋ[o 楘&wDZ]ȬTr=uݫ]2nh4)v?٘0kWdtl ԃ<QtϜrib7&il Ә~K2§K zIR>O!K~c׭v1 T4b ʑ|S mF9[Odru7]aN4˝.WqԷju/7_tAG7<ۆ}5'l3 &,qb&@e8FK9"|:k/_?Hoz+byTChoߧ:-LX00000aqskf# LX0a',HH-uwU谸|h``````‚ i LX0aŨ-Ma &,FXtl sLX00000a1E"hc````;`‚ )Z h `````bj+he````;`‚ &,`‚ &,`‚a +ha````;+‚aHǜzϲdAwyفؔ΄7A30000a1EOH Do&,ln24Xwen3`ܞM^.,6}K*=,,8"ö1 a mDE~Klpr79&,6`mLX000000a6mܢlL\m"hb````;`‚mlch 000000aٶ mDlaapL_fX?[g󏻼jE㫝i=Y74{zݝʗz?fF"V_i7:W!QuY_s>RQ`o6+ݖFx^آsKZ@200a6&,`mƉ`Ñ\HjF^)Y~=Ϸ_޸˯@sZ`˭j[u9)Ol[{f9P[!:tVߤڭx?ӊA<8Ɯ*Z'{"m_-hb<$,mlC?h'?Hi100a6&,氰&*_)ulta"q4!'N /Qu^C/l^# cIxeeCotPXLu&-,i' @c v8`)|< 34q}tֻ t^挏OcDm:EфE'`~':c)>[q\{ɵ=roemmmv@ #k;ob6l%^A|`Rf?J#,&cu} qo===U0zhg,l ۦPX&*m QiOy GZ&Gt5zx5w!ai9Yt_vGB⶛Z?*92ځ"T8N۬ x9Bc8{w :[ց|bkjaej8[*Ìxȶ@CbqX\9|( 1(/6ժbխF#7vpb`E,nX#p%[ꨕ9h?PIŽ>9!VD:l#L1av?c‚mLXD졥@k,ߓMxE8aB _ArL ra[v$co{FJ$ͤN͵.3YD#tZcîseb~|l`_\!B pqx 􏿻j( i0tImKU6 ).i2d``‚-,޽;x#Ǐ޹sgp n۶?G}F3j*>OӈYYY?I3Z]BaCLXmn zdv#cB+g$B# yhxxCAB^1s@ln45)LH2 .&,3dDtl:E :_V``D ֳW4Υ79UfOaEn)bAiUd@p%G2A8\/W`'bfGL86z憎1~Qap 790B#S[X G?j555>K7'# ItZX=Fsz1&a'zea< ",b7yVX]|0'C#|ؠa)%@6 >d^5Т7zE[!=\\A1@ y`{05Z200a6&,&7~-, "֭[7^g 0CeP({Ϟ=#ϛ7a1Z]bXЂfŃ{vaoU^Ͷq0MZuvcaʋ-M6MvK8);4zT#)q3j 矄"jNN:-\#LX̶ ,K%uB~].(0%Smmm&t^+WLR(mʅ YQd7j&,1fnaqIwvvK3 oeB']\\/@P.s= ^ g,-Z/Bpd21aٯ6[J*DZҪuє03H4UX`dѳ>;5*dz K,CP曃w'`);&&l6O;?Luj 6M``````‚ctaA6cٰ| [NN/m/6Zw  @aVߴկurc>RVC~dAߣm ȍ^d‚YLfȖ418S6ֻ@ȇ6Ժ*_Mz^^Z/ eWxxʍo8~cOT=QTHcI5ʸZ[@ʗg߱Q|ZR8y(ͱZ> ''|jmÁ7._em<6L-Vv.ᅅX5nߝg7޺VԚO-:l[*߼m ml_QpO XwwV)?Ro"qr%[iPF?ڐ؍t{u@Y TףK@|ٕ%v B6G˵&9U&EיĎh]7x%GfE` 7+Ǐ}4&g F B7hK'hHaLk1|JSO#o-?;mI+? `$ &,`ۦMXdVhAqc^s LЊfesͶ:mI]ǑOK}̙63ךdh˪}ʏꏴjh'JQ !>=Yw$0]̥'`-|>\ ҄t[NnPIk3V١Ӵֆȷ^b<k =﮼Ћ17É9V"ƄLuED,Z#c4aAy؈be15m.k_9_ ǣb@@!'^ ²ڑEҡogК^k ZwWzE۠L-p?SlW}maNiX(bw[Gf-2a,,~lc&O@ M9d)ƑLJͧqo!1ЗIF^lI vA`r"i׹r'og+N!aӧBיGd['q-~xcb7o#]3!;5" wK׆Y6ga R!KO傸TtB0Qa?H{wJ 7}H.9]6-XCe`I FńZB!&F4iOLu\x @!~a /Ei3c4aK/+mp}H 3D+B Ćh|'KeЛȒ,(FX_;cD4 DݮWhMy؃KahLZVH_KА::5CbDŽŬ& 3I5PHȩVo>Qo9G]:PgU/ۇDӭZ C'>8G(Ii_֌Nyp]bUhlbR^P[#FzE',J) jM"{戉>;Tyv]jˮ6}ޫjZ% qjWzX6^2)->>>=t{`dFRIhTe67 b+ b>BWD8H ^N+eg'\ٰ!>F|DC"sgXf G"עumq%u//]-VH?le 'ؖ >hן/H?Eb_Xx; 3CXظM#8݄8tk9"֫]24r܁\ &q誘-XJP6?"ˉa}+bK+/PaT|;ooBH^&]Zz__FbnH`i8QeT t7$tע:A6$~|FӖmX@ c/6Fao2C2OW`G'ƋګU[q/Cm>gITdY-u@ -6F__mpζt͐ɪoc 3BXhlAdUUh{FTd5*42}ߘ&|FK4y!7iGTUU#*su|/q3 OфZC/ QѯwN&Mq'f5{lζwͼ텞vwh0E__L z ̬Aީ.‘h\M옭gLhk.dLX00000a,¥LάZZikJ]{Plp*Ow[i*cN0,,z7f"fW20000qa10 @ΫR|^G5lkzU*sp4jkP)fZh(Mi g```B 1EHk7i Y{(Dۣ]L](gOEopЩ䈙0O}w[D82ou`Wqdu{ܙqcf+іxw {MʑM SهN6ZlE:H;cW̩bg1˶f;:yz:bs1E7wfxfm=(zG2ZlD-Ribf }n<}巯@rҀkSxm<^bSJPPoю/|Ӂ-,A_yimY%byrY~NMfUDy*sJXXc$Γ9I:| /9%?XgAcIu-|#K"] 3tUOyoĮuG X :qط,&3֨}yKO;+/u~E8?$Z0ԇ}oP$vA@`6d2L'{nAQX˕6M|Q;>/|>gQCdGs֢SGXk;wy^T!Cbyy{?_8_%\L7&uxM[A(mچ/lca=o8߃SeԅK> =I_L<֐訲LGDC\ߑ#7Yᄜϩ6`>LXan j\Hl:u#{u߅+(~W7tDcɑ;uRc?Ijx=w_*/O6M͕ l<9yM*;D,YwlHcs޻l{"&}/iKdw:X.CXXMddbW.w~~| G ˶tdũoBd4r7{[x㛏juIud u‚#ev ޢ?NOONx*P|scINiхlA@jʀ]Q9+F6#]8?bbK=l&Rf \h'S 5p,N##}#s8Ɗ,RX\?/}ۋ/~e:ﯽⁿtĚaHVr%P e32կ/ ~f||aI^OO6@ ۖ yw-+}3MG} }ڹ['Z=C Kߙxao?~6#W .wsD r7<*~hy1Ew Vb Mc*z1AG8A@|%։r~p*\ޟp;Oߞn t WMʀya1ϸ%鋘$^xl9}Ft'7 J^0 =i!v˗Wv gÃ<6w]A9sElnMb_e Az1bn@FIkʔhz(V*T1O8WxZT/Dۣ>c ϬHH}o7;Dr]2'4^k y9?V:B? &A\tA쁿N'yAL's~g/j)qrg[hhmG i7/iwW_r鐯R62v=bpõdHuFC-ֶmt" b bb'Fe᮫|>WB^Knil' o%{a}k`NͳsYXtu j$ƀ ՃZc>>rۜ}`ȭhX~_Vۏ|(Ki/-;~"CnϬ|ݽ|VLuPڟouc{mJ[<~m#oq6txݥ[dcvv1{0g!|41$-_o^O,\1!qWXpNk6) -YUz-!ua"R¶p~o / Bךּ!e=>qU#$htYKv14i$w>(C~b_(J &t0ҾT]H ]4ko +}藋6 ? 3z- A&v]>'S_P?-N;//w\O7Z@?&}X){38__T/>q2a1녅Cu!@f~2wT~8ds"TZU<.?o[XN{CHos#:gqGn#-mSVik🇖V\v!<7{|:7bejMeٟ~7cB\1{0f,vܜ 1' Ä17(=JDZ>=c%MF:"Aft%$'c3C#B8M #!& a]̒˭FG5bZ҃(q1 7cgRUz=H CobDZl=v! |B\0buW4f|x(/ zB42Yӭ!M ]~͌E}gED963{tc/a!&]Mbbv N=h9v*Nd˂KZ/8o}s6i8ro/tj?%/s-GC{ ݇.u=_8^\v|n2L}gE}̖g,#J\}&(ʿ~͍|ʣẙy&MFNt_Lw)-,vo^ޥ;X+ߪʋ2Æ[R::xݑ\|+"B"Of]6|r CErH.]b創[;b^>GʴCK#w{2\?~lJ[٢m : >:Q."~]Aֺg;e[S;Gkw H6>Q+\\u/~o;:fsG4 Gw0~9m6#ݦtlkl#} ' s`zNs Z {2ʵZ8p=LW/-p]jw*ƞk_F՛RYԑ^m:^h⃌9-,</Ã&=?{8ݾ7б7<O6PTC,7vHǑ{ߜsJgxVXKc+ɹ@8mzsiA %x8kLrU0koć]tsM?f挰 w3w%@lYas8" ?P2]ׅcߓ#"`zqJsDJIL0B+ZaAz??HݑbE?Q%bGxnICNFHlI ;Y$ͅ{1>pmGLr. e녟(ɮIm&GMir7vbAh"X~7VG4# DP;R'\ub+ZqIjJDŽ]>uR{s7;RZT.=}8;KNq_9L {g[ :cW',~wm1~xFڦԹ]@ ss3Xrn?>1m\ſIC n?ffPDW|i6O4#}<\܍iqehSH~"^,&8VǑH؋iʙjF ~tΩj@hmƋ73" @ILG~Е3~7_LX0U@`@0]I+ȕ @DJ' pkO&,fhc`xP_oVV\4_3¶ZN鑋o5z~:|B7m5EC虾oqa0 CGg KxRN.NöB60j]5Fٌfn/-%+̜@LF0gS%,Z沰p{ 3BX( \.O01+A^ÄLX00000L)5sYX8;] 3 sP0w0DžE'LĬr&0w0301;5(e````;‚a!w[aώ-܍a΀ z˄Ì@u Y˩6ize˟VzI߬铵d[&,ХP~7LĜ %0UvM.Ҩ#޽ni7bG$S;w]L~7oNqM%6锿_/,ZFԺ[Ѥ<+sf,~M4/~~{gzOi:r<\ǒL46i`7m"b```¢lfOvUkWk4Nj:%Pekǔ3^@8e-,绔ӮxԚMt]iRJԼRV9Ԩk􆭳Q+nq$ڒYm_+)F=3mrUvYM+yJybALǂk\:"m]th_rA,^(7\4L-AE.8xKg2l\a&b׾>߅@'/|!N-la|lC 'Ruä# 8Ԣ#eRWXŽF2T'l v_Իt y@&>Is<_HKEHU2§ݵ.$p.,#PQ##Nd mBƒtXoJqv`ɦ9V:mGabA@Ǹ֎.Ww5n鲘NiiaA+bOh%@k.w>3yŘ &Ih/¶61Pޢ }Ov_o8;ғc;W6Yt">s׃N#K_IO툶YugxZ]Khm^#-hb>C9p-LXp0000Da!vz]RZU`0NׁT=- s?z| |3I|O-Otc$Ujjvh)TLhz-ʀ HupJWH vÞ$?Ѣ%On^2QG]tHĖPGrZ}rVRԷdKe;R`~YUXƼe݈&ޟWjtmfx{xw7G5jZ6*mۦJ,P)I9'ƒ}CPD `Cy{#*Z)ى]ϋ-gvo;vy] _#.t=\^ݰ%{~.?W'}rN .0msm8_h? u-{ l,mv0 -@4qDd?H ',9t^/9mZ{8N#GB$ʉHBF A H‚Ebq&CAyx _SŚ};~jF,= } MoFQ (oB3!_eCPR Eh Yh[&,沰'[O.ےr󿯿SPqPڳ|Ww겸| .sovNE=o.?ugW\u U??L8q煮5]~t72:+1Y1ާޓ^evUw*s:شLQxc}r?P9 c h9v'x DE =_` G~Mh+ FmI?qć$ecv.SHh"FJ%Z 1h2M(6+zd>MBIf c{a).ivBƉh/D?\/=z./k'%%6ZUB.ݒ v` Vh7DV8aA#-lɲee_YL65&bV4-sSXX:DYѕSrOvcy={ž2ZFV}CbvFJ{m?VmJ>w|kbXN1mQ[Ҡw׏ncoӛovL$ ,,k"o9+x_"'ǃ/u7삀}gy0NoZ!lC{7O` T>m`s$p7}h%~Y5. }|RiZMG[s8bH'5pjTiC#R8_F]}=yISBR K[Or6]śRtUmR,B}G<V鏎4=]phzk+aDzmivf.[/NϐH,~dwz;$:/]m8趉6_78RI6(E[p@#|@>BXR;aVCDg7 ~¾C#(1i$Gm a>1zܗ2t^v8"NƖb]ssZXH(o29枛^U4s;w& o>XsbS0ʍ<}&ЮZOΓu,ے '?84Фt;6ܐX 2 uLkz(Fo/>Q•IlH3pO+`["u~[&s'+f53{vug̦Mr#\ڢZ #O<|C!6d*܈b}u: lFAvdWܤo=ޛȇv+m0H=vK2ӊ;ȹkFKYEJcKXh":<:϶xѿ>.'m\ ^/ pi$^YĵpnMuEW{줭sa97n/?ʼnboL?t,7\*aan4P'˜_JtVC"949RGmDL1uߑ2;V@?(؈7Ljc !6njw[\m#p$mX{qAW p籁r{!,d̨?U݈Y O{"S8x]'(,}A~ZXoAlý t`6-8L HRߣg!"DXH@i2c~&˖nk0Q~QaA &(̮%j |mzؗ/7:+O=}ȃÉ&=VNXXA8&et)vOz/GcP?Fc=/>]!O$qVfm鸴(d֑[u"RuW;SI]>gr,fX{quG{6F9 ׊.b.׿:/VTϞ"}K3.'47I՝t%27OcEe AV-D[乓hAwCm ^Bw.<~{w]!ڂ{6´Ck;vşṕ5z03ks<3‚Q7/; 13g!2}8nq ƑG#GDpnG:w-,#I ]hrAI(K ȿlKp~B k9pyL/C I˃ot&Zbx f_#eR[4l"Fae]&U-R{ A>8؏v%$ 'TVA]J O1.Oo 6G9rͮk"Fx mrBzʅbI/µwO]WciC(G-@,D8fh *-D$x[cte20Ht&Z\jSṰ?|d*Yg kً9-,s$T?y|]+ =UiOz~%Z%R0:f{3~6i<RϟY[o]b@߼)oG,'|j~]m!`cq`;lmQuX9œW<DZp!?F7/lh#O<دmMe[]0fe:]ͷDe]r7?o1O{@z)vmU1Ah'uѱcFOe/߮t98 hu;ԉTX3xJN+ayΓ~Ѭ찆k/te#Bɵqp!Im>"~F|0+E+w d@UxNT_iW4c-a vjzw%WVocm51E &-Rl`bq6 HS|ah 2QgeQ{Ϳ}eMP|M.H+@ja⯜bG~n|8-$>F_LX|\۟|B?o@Q/|٭-RL-_ќGk~]WTj yU;qⲼbqynNg}tv?~qz }ʎhgL椰``````AAc$WyR`9$wVڎs C_CҒ}#`|՞绸<ˍ=; bđrXy ?ӊAC @xSb/ٕZ"V 9t?^pԵ9,;!^ӓ ?7g}['kz^ůoI.ݜ EX4F 1Xk"5rO3ijEIu~?j{-Xyb lh+civCϴ9%,ps,k|S'<7-W:%HSlYqrh?hg2^y'RT5(G& Ho8!UNfRiX)>7muD!kHmLvL1~i:tϥ*DIMoU&:[N\LuL\O.:s&q5Y.BLPeVe  \- 0ሙIO0>X7!>{s%sKO4S؀WmWɷƖ dDjтx]Qm.8ʗo3`$آ\H!ǛS˸.9b=Z4hMX́}w.i{ƒ19IP }m+#%ٓi 5f v7*?LҢC~-fΑ8]e1l dT[Yi8Fݫں%O?7dqAګ]nWF׼OO"0!1LARQ7AIjC6DC˩|G9Ї-#w}dj3l{kH 0fBo.t<rC볜x/BΪ8f| c"P?=?Z@:>6"ED8@L-@4m=B]/}~H׍,)c:9#,@C;GIAMp^lS@p5[0rg10HHcHF:,uIyw37M!RHXBI_8GEHaĞą;VdS5taD;DK+o`ayhL rh<8AT˵ FA!f4!FϏ\cm Q $A}G CDraۮp‚n2jO1Ma+ >'mDfcAS [RLXa|bIxA$Ȍ !^>f9[H}z!$LX0a(,@hĈ`FXBe0>cˤ0 rO`K%0F/+w,&,@rhP>Oz`? I1H%[hGNd(gTa EҧsDd Hfϣ +,D:PF6z~L^ $$ȇ+Dx%ZdD;ZpNB~;YX 4aAb2Ev&cE[eHXCi0%R[O$?/&,y 3 i]:g,hϯ35F0A n1X:)hLt"Ox%$9dąm>UTpqju |{`|hpD2[ :}+f@Fܱ+ `)f.#ȃX}# ,XNX`8bhw}KeomlLB#қ5"@ސg@P?DjsѾ*3Ğ rmv"I"DbNX8g,=OgW3000Da2B*|~+>m.XOJ'Ą<?{Z  b # dXa!FP>C 6a%H>< :{2&i@@#-.l`p^QBp!M>% yvĞ^":Ėi36 ɏ6CcHLXM/0Mf0R?f/]x~z{2?aA/o[^6D5%R[Oឱf=Q'LXKXظ8 ĜH o@`ȟpO,X>C?;U- 'z'tStf6N4 } xjhf "GLwA{ax}T}$ LGLXaU 3sJX IH!~|a1}J9%,2pFRrĉt7 ^|fD|M!{ Q&r:m AT׫M>ɴ^d~3W9a-,ADBoGlϞ^rv1\ -^%ʡV n8ZTXVn6ӽN:"i5vH }\ΪzaT7^Lm4?RLXf1%OcvL`&烂9',0:KmV14;ZلdήgdiN?%g`" DsЋ2f;WLm ^̒k@yƬ*6^rD@\EAQ"O!R &]@zF'*h;2+t:q9(V!=L{|;h0A95 LX7ސ0KXA>7ALx7Do->bF~>~,oS3a'vhfD~6ൿ?LsJ~_xa9R#xx|EcC?"g`b KGG7mZҷze*|=m :?ȊV6$v; >%ǽKt'0oɾ>s$wV]f\C8w$'Gk-}jaF ̰{rGP.!:v4<  ^ إ)Pa%1,j@}Xi|{[x_.qňEvĂ/[|Kk30S79ߍ yhxo~tbvo`ߥJ+{i ~_.+w7Z5L80a(|,2>J7΁k%߱7RL8trײ7,%_A&Q{nIF?{qg wvo`~ʻl[-Ɋr"E)ss& @ 0y3)Мs~0}owu׺KfH}/\5ǜDm2x?qQ[#֡HXF xDxk'+vXX&ŻlQc1{E)cwa"%9/w@U[]3kBlQi-p:iPĤk,66z@AUG h4NeCm8Rl>׮z=#t=]5ݎtuf |cbD8pd_=*]Q݌zT[D\Hkǚpk&sAmjX7׊;O]3 p*y`OG<Жmrl_ԁ3ZqD0mKPEW/ؖaǾVowK1.P'LrlKve6A8z&hKC3Y[AϿaʓA'?\dabNo*p 8NܓZ# yK%[Ŵi Xt(&Hb +/i0B,* [ҍCk|}́ԅhk#,hxWi;, Ї5P^ 1h ?xp 16r<އc!b!ޡD؈UkQxb:-H'{:$L(xaĻivXe;Oq! ߩw.ĊH!|b?p v{X1q!ckLXmu8o o}kvOzcx):S-mƫ M웾U-5PoDzmCȥPkͽiN_э2 aaIĆu`3˻^ih/o6f\ &^O,ED_mԁ㑧)E06.|ESD .Tdl.y"P}:]}Ќ}EnUI4j̖6y:?Yq)x١6mH-[t5D>rcp,-Upb>*21_@E=&78V W&!tB 4 ,Qq2A; =aywZBmZQ5.  hMkm%Tqq*oLbu_a-wgĊ".w B 7:[Ղ;t, Y팶#ȁF@|`dXRuf:b@b}´`eĆ2 a*/?Q0bDaW C^Uji;< cAD5xh;nLeC`\h_ /Aa%F (Sw:ZyK83HRtq@ѩoUEa? )qs]s.NJ4s%)\<҈)0 U{wFc1 ]7.ڑeU!<{Ezx)V_2jݍMH/^[F?DSiMmG.շ_׷"o?׮ TE֋mU*1g]5Ci>pg.P?K)E"mrrWNWi33AT`OۦؗQfmBʫr4m_iPχ^[Zw+_Ww؇V3*kҏ/U Ct2.pw7✶K'/hPpHT1 "9b *#NWkqbljS ߜ{#WuB0Od%juӺ ߪp9ħkg\tX'_l{\ ÕV\I\ECWtXX@aZӠ5N H)4}g,e"Υ*.GMbB#+&SDpU ?!xey m;b[#V^. HjC=y}1%*瑌J?b9Z/_y$R_'}&(ODT"u̖L֤_g,>*m΢<FߟT'L)259UEn։1-e,hۘ7ևkU S&'t6{)}];.ڞeh:r <֨;|Հ_tYۗR>8P_(q54"xu"R:Jrފ@jeۥbS3)6>[ +ƔܶzU\>ڊ:}Ӡt1*[K_u4{ O9^ĈG*0(G:e;Z&Unmq .|H=z6[7,^įNRʛ [6ךq@G:Ln*qV|(m^Gz&ĸ{Vl0zyemVF;cJzC 3פkCu@MN;W!Np5']!ot:!+t!nW|4ޱW1 }btX\/X ob  y Ĺ6ЊL8V< mqA*uA Q4*#5 O # Xw,5kw'j5>Gfg]ɗco C[S2u╅`"}M j!J/OjhKo`,Iwp/h,s^f"\/kJ~hzSxcHM_ A4u縦-Lvy#5m H/^[Ԧ^vC#? u:mhǒ&O]볏 FkEyma7F3vy{SZ[[DwK}f-ơ"7xG(RI;_+yNo*pJ=cX$iM'_9~q"1y$r(fćqb+ބ/ێx!Ĉ? ^[uAxNCHOpw!d!gmH3a76[oB @ DHo D @> ѯ J#vh㕧B%R_1}^ZqAcGA'bǔ87ݝOH%V(Hc57+%D؏7N`fp@'~'^hIHi';0~ ٠z͑UH{DbLHq|u5J;XR$α}]0ZADkі%I0~^18d; Za#meG8Y?*ŃCF_A\iuQpB#ؕEKH{e">RMȐŝu &?bU xXoqwCl>-rS1sŴ@wuXZcTI["&XS@"?mv"NA1Nw<`#m1I^f2iNVhHq;x0."v{2^,Xĺ#_XswhĴ'?NhW5pu"yLV+큫/5OXln|SWM.Nu, (־>S \W[!ZgcjGSao~DcYu˒j6u,qV/h-n{}WG7G{ߣW]E+kGefU;w#=%Lݞ|[~^MX$`,F㞔jԺV-_ih7Ec*|1l~ѴsF֛Rd$p;V .GC;V%v,cA$IcqBCz%3IJ_\z'uFD^PQMX$rΫ7uWuHVT@U>z)g,H$I{XTLbͯ9jeJu-Y3R>l2yArG}5hmoAJn ͊()ל#uHꚳ)+.=jZ8Z_+3_g&?rk;#;Z'T'I$IcqO7RD^[zZ{q/DrmJؚ\Z)6^6]}"H$Ep7$j9p:aeXSzRʞhhyRc""clm䫒@;/xPqd z|/#^=zThhS4$I$Že,',]}T BǛZի*|`q›_W詜1ش%FY^+wmxR27^Q~rc"F14 =?6s:#X=\N o{x}9I){fmoxh# PXm{T8*7V >761hI߽Apax,Ƣߕ^xߴicZ7]AxطB]wK=zݝ8oj"]7]3*8rGkDʤ I$i,9O6u 1@šN+^ %ӈ)1E2V_= *5p`\w\TҾ!Mkm3LEc@^meΏM٣?g\59ʱx2҉E`Ք_2oMl BMj:90x[ܭՊQjnm)+'c§(bbF9!R$)myZK-~W_ĊuzubO::wH}W_4cX-]:g8_ޣh󷹗Ƃ$IkXs!!eca0bJuy-lc'\];W7Ş/AE=D^ CtB@b1QďH뽈uvPy8ڸXkHg}x@ؗSBY^X!B;$[H׏c,Lv-;Yo/ֺ:[zE(ūh5Zm I$yr"wYVec \bڕc, 2(oٯӹzap],l!%!~1/mzm[ a)[*~v̮pTC\ZHR&B`P -i;YoCL{6zkh{IWkLcA$I5包|" "sƱ,1E +A/_>2c15gtRz`:(!o"֕gYcƋ|sU" 1yAG-KK`kcuܔnӡOЯьmr.; gL0XTt#{-6X$IcGXۘ."2ZLzݝ`A!^ pT%Vfq .|Hų +O#|F:L] PĂVҠo"C o1%gID}b=cq]>D--dl{-6X$IB^tނvT+LcA$IuߜpDL Y< -yk0Syfn$źj?MXX$IEc!HyxX \[zbh*{x7IcAcA$ɓI$#K$IXG$#K$IsI$I$ɓy$I4%IɋƂ$I%I$i,x#I%I$y9$IƂ$Iɋ<$I Ȓ$IEcA$fȒ$I4<$fȒ$IxxFAw*b^γw.J^}7ql*;_9jyfx}wA`, Ucqܩôj~ye}d"6#kKXA4$y't{M֮W ~w62ZXi509}HXA{H$Ir   rr I$ɱƂ  I$i,  $IƂ E$I$J Ƃ$I  h,H$I .3_$B$Ic%AAcA$IXAk,H$IroXA4$Ix4tƂ f,0I$I4AI$IcAAX$I4Ag,B$I$9VXA9!;xwuBV0"IƂ 򄃉,LJyѾ_je'7xt)Ggh[?盍z[pE%4Z:3_?mɣngo]I+ g{1O5eU03ή1ƣlH/jαMi, £ FaE%}W(a';Ͼ/kG_F"6+NY+/6S">Ŀ6]DuvrGbY9$I.6|qeב|IĂklC}p'inꌛ^[{uwG~qn 0MiPw>ԇt:cg~GhDU}\i7c_`ЎOM'+)+xFa|&ڧrO]9]+'^I4AĘE޵60clhknwv/x;y2]HSkE5 sJn0 QbB4~x8էk6-A|>|?ZyHQv 䗏^mG TfOfңc_L=DTVdü/gcw%")C6hG=V)3Sf:ۋ4G(T. py;^;tLlFS9Ă{F)ԕMp$A1FcQT18ݤCK6!p B/viH\@xNX⪲\g= JP{`h eD9JewX.T֊+O^;\"6Q`ؙ ϗ~r8O"We!rD b";9A;%;GO/ᘤ2dc14f vBߔګs76(>Xcw5u$IcAcAAc=!"Ѩ?=ޱ4ۃ?{qu1E,6WSs1BL -7b^\=0VcERzŕGySy{#X}ۑ֜핏Y/[odP³pŞm6^O/8sr}ib~ %6ñ0r~5~2Bݷ`Nܞ?zfuQ&=~XǏ46ڧVL^7ϸ%ɩD bBSo ]}gKTv.&NRXh\r!nc`>P.DyUU,˨ ;C#)eb 1m5'{ VBFW00"0FSrҶb0XDpIQ-m!;D?W0rN^"2}WB~8uCY9%:0wg7Rxk jTpGӷ\>Lne‘$i,  h/kXt8xi7:Ս@JrWFe<P|jֻww+"oWSD\7і<~E-wk큌P"Vk3/'w83ƅ!>7PS|0bL~VĻjgՅ~|m,j U[FXF2xG[>XFjnCǠ>:8 :wdtAꔧR]P[fmaȿ1Z "?Nۇ1^JOFOd|XAc6Eu79 {i49kjwh !t5M8.Vqrt0A"?#u0 wD()'넬#liH?y6Sפ >|ֹ:U?~*v@֜둧!e|%)$Oڬm^#/F{̽!T}5?= ,yIXA4M=D88k_[rw"N}8Z8:miʊW?\]7NBtW+c>%^y ڲ])[=Zg,dK4A]F!~[ up;`)UJ$I b-dyGrꂷ]p{I*ߟIIcAAXXAjUA&4ht"b sfqkOXnx W _aA}`x#I ^1.QO/VQ}>>؟7!u͊PU[5/7pWx7#lPZ]_=vwhXYݑU{#.U4Vn1v鄱{棝}b̓C)e!nXz,x>koV. cҩy~H\C9al[# Z:!+_( ??ҫc4i`$}! ^@PYktkr8OmS@Ŋ'+"L1EusiTaPgzRLjwoo/5ϤENΧҪ'/Wn`4`Rmos0.r׶caCF4A=b,g4ZA?/D<sjd#=`hޟjчvowԖ{Ygm<(GL_+ "\V_[޾%~ivoXp!ʁ?c*l^Ąo׿Zk*أ> +ryP8ÎG]>\tsw!^bO\`jf0xzum_q#AzQMcJvǠ,Eh>z]3nŪ/Hh~H+V5ڼ)RO1Am~GC8*K٥mRVNY/I!A1LmSwQ'0iŦ^C2BB,tǺQ. sa tN$<ɮِ}x7I6 Cy!G_Z5lL։3c6lD+7Ri+Olw/&V_eCS>]zwUiM XPA;Q$AqDbh&D{\-2M@qev*H\x"2sjhR͊c\?]磨%i, q,V>o#le~"ߟZ<`rfթkڪ_ŕfoI+ ZxͯfCgDbnw5YX i, X(WV_.hsUz5]^9ۮ) ?Bx7ܳצz}kS_eSGwC,92—ߞ\C^0wƾrj"}Ε xx8~ˑq;xokoS@M1 ,9Y;5 !fv.ݑ E&Zs.{->^o>ƾxqmgv@<TO{~?mK5`7>=lX+z|C#8>Vg=g>BXF/ȿfh X;tg3|/?A|+ız}]?ҡ)G[vI2?艗v7f+aB1# G85~nV ƽ_ێG _iN$yoƂ k4<}Ou)!|1Uþ:-G^.Vr\}.cnltrCUWnrt>Ξ[6\Z+-ĦNB{nkfD,#S򤴠b^v{gޑ`*m:vR]U*y+zƢ#8>GR+|,OxWiP'.kMӍؐ6%ۯ_m&k>Wf|cwMNiA!p6ze h}jTq>F|胱 ߣ|7jyOsYxdVҥxe3 SuS: {O_Y:PO-/]"Aޝ  l, ЄP՟ +7,& !x@]9χ81>"!cv7B lD9b]!!I }PXw7A -`D\B(X3.bd dcj;*f OUsڌ7ꟿ9y=+҃0M,aQD2;8̌V~yבwa 1Bxj&^7]DbtxhAy8YX{A2jE3Rdcj*q# )9Dmߊ'_/ƺJk-W>U5⥣@  nv " bd\UC A Q+D(D/]?0 _!O] GWWŝP b҂-;I@ J".8^/bIrp1r~b i-/+_yc}k c"lъxk$n܀nr^?<2w$Hb|;DD>'b,N^!?Xb "ʤƾLO+d1xe:7:^}m\W;!>^rRR 6R=!PօFL/^] MZ AѢaE~g2j=-.n>=\A<C"І <~K_0ObD_o,pbbztM6R'xK0)L Y'30~F^- Ҝˬycm>K7Y;^: t >1vXu\m·~"^Z.&1" C*!G(Rq\z`y"c@S;00.ץ-*(ɦ'\c)&iѺGR+T!VXq+w6 My}ݸbtozS?=>#+:<7E_b$oŮv/بMݑWu4^W#3^;J7D?7cx9Z U(c ;w@I7〼}   ;U4Viuks{}eroc[AϤ  Ƣ$I$J b*'h6z[A-#Aq_ #}bkଵIFdž-@6c /;qk2Z韱̘sˑ_YӇx&Z~~Q}l]1R:ů:e$IcAAL1c{zW]٥z7^sW69Z}۝yMhiW$eW_ȸotiM؟Y6@Y_X?K'Cg1H#L!H4Aĭ5a{"Lor#sw?֞'^iq>Kƾ`Gw]{gG˫*{kao{I;ʷ8CLc.=z5XYvhX`|/TO}[-o>UyiӶ3jTw<~#֤8pS\e66kmJ@ezbqn9Zm1y;{^twfG+ED[_R&Zվbw,cۻ:0VD.[7Z'C6Myew,jh#b.G}0bjT2^Ck4?,$cƂ ZjǻԒ" o~a>Zw>Q_5 6D!yeQsi ޗvqBjADBd>}ճX~f q FyRB_չBۢ06.Uu A sV_ov#@Aݴu0~yƞ ӊ[6@;=Snڂc!Ѯ2aZD\hW;EYpʨLE::ч0X _uB6S+F28XcP'4)]md,D}q }%΍"6*%  @P0$A1cakAqVtEAe\'LҮ 樑 |/ogFE؇c~^"WHlZ"*_=4F"BB߮O9. Qy[Y{G:\"0S+7<;z+u1B}o4&燋O]SYu樱@mC&FPulV;_|wiaFWbtv=qE\L k#z}0^\<0qGS4ApcFXCʨsړ}kH<)C-fсv'J5<ԫg+l{ DbR=qG(WTimI-C[WA=hlA\I xM3V zlVPevߣO~w9׶{إNF;szBsEw9jn;0hZR :jM[\O6'IrtXAcm˓286CU-ߥ>U# 6`;TE~1lvEoشǟjy<4%Ӯ;!4E\ZW#ƨSp\/|1ez V{ϔu?W>Dl7:ԶgU dG>A5.9G:f +#)i6SC[ar^kq!/m{qQwַ{խWG/VuU{0h V^[l~SqM\@r=H4ApcRN05YtKo ٖLWW(WQM+[>MfAU*B2$*ahāahݱ`k?{Ɏt>DK5͊ P۹>|Rن U0#ƨSn |j >>Y %}"5;6I;mo+\kHiRoFD̉?ҡ=V+B>sMJ8Ff%VC4m֠ Ǩϫ(eY*mM=b7v']b<0nP޳׺B]1+Ѿ!ɩN bpv[Cy1]uN|bw"xq8rPs#b}͍=\r{y f]Obcb۠ <Ʊ,:14u/{P}84˅:g/e>FǦoj,r6;Ûs0 vmo< j 9sy(>}C#i, q B:"c:K'f%IAi3?5ڼP>4DHnO>V5IXA4$;NI$AXfϚ09"l$o"AAcA$IXA4 oak+EI$A1¤KEe"nfmybJnS~ ^Azq7Cs*y+N$y+HcAAhE<^ֵ{,'FG<|&ςWVK׿ifa/m˝A|J ]w$[E bp('Qh_N_=[CJهdw{wsfWjXC`.t~4YBMF͊ Wҥ49ws#m.~/^ԏƎ}Lm* \*hߵYfj5iuXͼU7LyvWl~|٬FGB=~=]hm:'߭%q$j$I4AĘs.L,ۏ]QWc>˅=2o|u1<*]n@¹Qr29 ZcW7.y!hg )hœ\u@8":1zMBܯݗ!zHBs0ҕshG\/9G|Ƚf S$ՠZg]lWj 'ϯ{r*RR0$IcAAXtF=9ӤS6YvkȔ^ܮ _-hgcG76,vŃkZ,8eQ=U#js; + i]Ǧ!zJDEĴP?^^+?IR]NC1 f;^@,Hd{ /(Q1<ں 9Z]@JSg ZL!Sj^KYNz+&Q䏺/Ro$9HcAA 3FQئ?>-ZӢ"uٮ̮>M  =' tWFקNEuD{s;EY2O(;xy9fnVcny$y5e؝%|Ãq [#3ViI1PryޱpY4wiZmc$i, 15j ?qQ- rYh$W.עWh% *zI|gލEˌ6;L ŅV5KhXc!dN1#oLcjY& LP]i,H  i,q ^вF'k0=첾O],l2.ٙх^AA^ہF3bۼ2:TzCGUK/UsJӬ'Z-Ai4.z+l6Iqh/[pn\)n,lwZwW Vבݢ(ƚ^-ܖօv)sPos-VR#]Z&{2N9E!yDI$A1fcQie~^bMX\.7t웁yUr+ʃPsS(G)b@<+vaP >y (\;Somi^bOyo?~%E{յ=O}+# &$i, [b,^8X4n!z뻹M@8a~`pfQLS$i,  Xn'oI뚶vz$IN.i, ;j,k:Ye&˽~B_A$IcAAܓƂ$I  h,ȻmְA3=ҧHd ';-sȠSNtފe6v/h, a,w+Suֿ܁6[䶕iֿ<}_Pndp3|ʌé5nu]vdˊϖު~?>2wIk }hz0>-0 !mwBW<[-a=ba0ŕ,;POViz\k=[O/#S4A=c,[=Wj;XI/6p“ZD^A;Qctg hŊ;lKm!o0vY#sƪX;jMX/g_,c~s+zw%9ۧ6]zm{/هB#mnh d}1͊1wcѫN  N0dW\))W'[x§SD'nV|s?@߿=\iD+~Άg)RW(X=9%FPz\v{wx%e~.6ݳ$zm]*{eWf_-^^l8bj}jVyK!j?P(F+hrq|[튿`ghKz^_exC~ !~u["+}>_gV]w*uCy|m3y}HIkyFǬ=PD.?Djw+ڥv͗100\'G/^LX"7[.w 2Qw9 [c6[w=}^4/PVK(njlh}Ly+SUڏ]H?F7Xmwu^Bc5z9qb GlYӡ A{w+ Ɓ e"O&N b\'e!!p'vY !{B)wX@N3( >!Bʚ]SEȪ}.+ o<'Ja,X`ÌB%+ȱ .&]*@sEhm_K0Y'/P~[ںfja 1_a䶍u,Chc-<o2BԚ[I,# |8q`ԧQ#r=)Q ! &b~QW{X0Ɵ:WhsN<ݎ0be2Q"nE}-Aq Fc@=?DGKN{eA/ r+UV#WV6(S,TY?c&k!BMe0HҌ}ӈϲf Bnb^R #+, Z;j34#zC@+βPԚQYk.X*#˵b܇Wn;OmxPoS`p=Vuya\XOc S᪽w`T;5z"j{$k -UkNF([nW;  c!哻aфB + w JX`Z]nYĻS X+o,5?{ŕg mo;cONx9'm3ɘ 19 $,$slusTΡ[o..V%:y΃*[]/)dF Rn+JnNeςմؿc1ȃRXh0f WE۸b,LA23X*2ĜBŭ%t Z&OyC:ql*>t U,P΅1m /(8i; Ff e9,5  c= 0Oȱ8Ǖh?, KЄ!  bm ċv4}2 [j}{<ʃM%:Gjk~ }K_Jo8X)iKa 4`WmT:<|_eж,9ӖYVxcjG=ꏞ/߈k<`*` ƕk cpھV!a r:s 爈ϯo}==E86paBfƂ Scg'-Rc+e|ٮ/V.@aW:,%Vkâ=gfٻ63Kk;&[ǦdeVۻ-'r4s[E2b<+ňUHeuhr/c?\>3d;#2q}{_=u.J1;ns>6^ss.{N݉  Xキ ӗl0{z% 0D IN`b0<7˩KkՁǹWdh2汊[ɴA1‚+Z{Rӡ\kJ5m۲/v6k\$.t4wcFX7v4Q~beM.t9BXĭ晴Wbc,  &X$I4A]l,u}&rttFפwkնn7$&X?g(c9YP)z{]?E 0%6M_,?stlށ_ :ǖ9u+Dz;ؘ tMV̲:ֆZ,1'ߞ-~úw6jmv*w̫pVH8D_OLs<=H:DF?󼢱  h,ƘNf8탿ZXZ-(KlZƄ_ŪscWf ш=[ݷxn3iFOjnvdVy-:B@m>f+'&wDc #mt5y:v]Zjenhl`pnp{^4A \p3e\{]ݹ&dl(̯{{^p8NXNm޴˩h`'\={F}џ`˄6R Ng|qdI1TX;M0.Voy=~ԎE%Ǧmϩ$S+'^hF=1&ǽD/SG\dcJbՌp V\sNy_YİbWZߜm9X%AyMR!Dyv@ƌ18>cMkuN8q,'c"1g׉FhN;)zbsRr;" kOTtމ!>q_ȴ if@\uV`J}ƋM=)3t;%(-Z!Yp]_!$F297Oբsw(cml/gfr7ʢ^%=Spus;<\*s3yvV˨G8?W$AFctgrRPmA4qYVX(먷&@@*"&Bn8U20 Q+촨4_w, !*LWW!@mcH[w?%8)TٺM6 XȂ'yJ88}#|TrlU) 1N=frhjC5myyFk?XCɃ& 󊤱  Xދ_T+zu@-X.&(E 'A!utp(EĒ#F2G1)Ś,GnR|mFZ-ّ(e239ո: xnدȋR+Ek!_\]eE%d;zz* 籗L>*QgfDT mI,o-ԷP魉J;VۛL~0qYa0*$MmlcIʽO?jLۈ:$pX<-mimedôDnBE6VL $tgJ(΂m܁hq_̶$v`2VMG+5ygkh_Yrˊm'<P - D# Dբmzfʝd+ۂHԕB ! S V;}!LM/b9]ݧ娧kQۈc{c 9S5bS=\ 0XgR9B~mOQ5anR @c2y$+gfB2V p<1ւs⽅XP㋯ cm{wNf3h, |9_~ո®چXXH"_g$/|I2[~T6UʊK9.}ZW~lnR˷Xf!N$W[Qbur$lc[Q3h,Ϯ=_?$Y/4:QBʶoOC[bޣL3LV\}*Lu O upT$ R"I=NC1PGY֭c`Po_lC>%j. uL/ۿ,0+: q'ü|W0ؗ-}J$A<(awds-r>7ıNL.7 r+[O\:(!1S9RWGXAjc sVO[( a-KvԾ:H(h{$JN78%96 f[j|]dPo]|9Y;E?m[eI_b) (\>n+MIoDo|u)q6#uw% /W4<.8>_sQ3,|fVXJ1/. [{WWQVA/Vi}|b&ã_?hه[0   \򃺩E5YP4Jbs"E?bчdh[9սb(l9}Eq-myxxRYׇ3Έ}n6c>g ʬ:wZ8Aș8 4ܣMqw,1up.*O}m bBIx,3w Gؖx~u ˗25vS7ҹF<Q}/E.*֛1ƴuN0` pFY ̵R7 ㋯ DH>>i#bs~pAcAAl,HRɤO(we(,y nZ+Zq,hvE&,UN ?a1b wLuULhmOFZԊ1{tWQ Zޘw5j4\Tp,FKXA4"}<}WBmzWS$!x,ͳ|ٴCቤq=mxCe_l9GzkZZ*q &xtplx%(xI bB[ W̴ClgO,?|ʈβ۔ۂs> dw<`3A,qJi;q4862+"V{+l2Ʉ' فfſ~/Lɤcp _Y׍D(D*FЎSď&1D ?[yz}F3huq@y$9Xtڎviީs$x'=Aqc5Z ^PXB$ʊm\8؄~'L ,A :jb/hEL-ʩX8xĒ"i+܁A[Xm'a,㉥"C`ܢ $=2m{&e2Os{юJ#y|+Bܾ6Xz\ 7#ϸbmTD?dNd +M,՘3`ڇF )Mt^W=6sLEս7VV}&_Ѿ;Lxkz0ט%8 Kǀzɡ8'ı)Qw&08QW^]i& w12.  c\ 8[~o,wT@{ ';Dh[SsuZ Q\#P?,bb)Zp)%bD%1 %Ĝ>8apH 1%NJb隸b-|'L ʰE}\\W) -PymbISC}aJ#xFc49<ɾo,Rީ 9N|pžƂ :ub?D6o[r,n1 KPNK+crXA8aZ 1~?$k 43eZ~rp$(U ˋ+"'TnT (>>p0Ń☀pUX|Ο]0bdXùGܕcDc1>39#tA)PWb,tT-{6ԢY\}{D^XF?فfǿ=y8wCbǀx/i>>22,_~ľ˶<109C.e;Wy34IXA4v+_VXKl/ڑ|0 m|=Fa\N Mk/$qxihoҨ:yY)a,{oG$S5R) o`E.<]/Kex#2ʩ쯾Z KqcS,R_̣"E7= ڼc3__G0c~ IXAX\23h,00bxxxIVzYsԨAq+FJ]&bu|xa WF4ѱ$ޟwK>G,[R|LP-Ɣ/:$99 *> ˓PwD};Ng"K AKܰyAK3Xqw|pl^*G4AĤ60J! c!A:ʇJ%J=,7 z0,ܞ}@C">"w.U~)LrZ/ (ۆR ClkWTWXn=Zw[@1ܕ;, qSrbܢwDpwRKq\(ϔ E%IXA! 3\\M @y`u>b0+xB}]j4cX B!aZ`(N$TBF7꿸gGp\!S&D|6{E)DǙtK&akݱЊy4}Dp !/Wкc3XƉaR{fbs&&̋$i, <-3%Q<\=Kp5LI+x/[w$ׂ_BlC g, L!ۥQ_Vk60q1㛳1ޅ6/0和!o(S_*? Rs<!pqAk=/Hx.)E?y  蕱9>/?=ɾ9ĸ@X_ ם2gOJ  B0tA,Ra,36b <8,>|0,qUgXܴŧ1O p,L`,' WE}nĆ_bidBJ  B07;h<<!G \ƾx#x@X kUSF`*v.Pkqy|4'I Ƃ4X~x|`[A$AAcAN0ixdž{I4AI$IcAAXˑ$I  h,H$I Ƃ$I  h,H$I Ƃ_$I$AAcA$IXA4$I$AAcA$IXA44$I$AAcA$IXA4$I$AAcA$IXA44$I$AAcA$IXA4$I$AAcA$IXXAXX$I4AI$IcAAX$I4AI$IcAcAAX$I4AI$IcAAX$I4AI$IcAcAAX$I4AI$IcAAX$I4A]e,H$Ir47*A$GdN_$=#M0MNw;Q  .%R,3f   rL   B6WoȤ   "dS!@sAAAĨLAAAa14AAAT\AAm,Ȝtf   &1Nvnj`1$AAALAAAcAAAAAA4AAAXXAA1 h f  B[,Ol$I.KMK1I/?$Ir,oZ If,{$IdHcA1y5$I i, &蒾H$I2L Ƣ*I$I4A4$I$IcAAl,$IdHcA1IEgWo?I$I4AXtJ_$9,ӹN)+cg]Cg=S}ozG\UWUSWxu<ϟXݓqDގ Ƣ$'~Y{f6sk賶g]vۗYڬ}KcsoWǢp/[|<ے4A4$9!"_SoFw6yպξ>{}ƒ`]}_z0.裲WTueʌ׳-s$cxSuszX2 |zō}QW16t-w}>Vv_Ͽ9-ǩ,k 7PwUtUmD^tk)Ƃ hc%ɉd,ҧ?}|um&{So9xM]3jm}{_݃oiUoG숗8=-=)ŝIBM6=Od˱.Wy7; [2ӕm}qX"zO\'.N27˴{{nwo歏 3u!}on"oXALRcC|Pfhw:Gk&]E˅>a,< , t{A271Kߏ6xm dXv0~ssu.?E=&o8Ix]c_Zn}%뛺zs%Òm7KchـW8`\wdX:c]HcA1y$'*Qk;Wd|' 5۞v6t$}oeSoGx]iXO2Cʉ>3Xf$t{=?Drdl/IN>'de>l;v\k,}Zi萷Vcsُw_R,}zs aQOY+X-:LSi7{/\Kt(/urZ fYe$cE;".uS#n4H̏/ϒ"oXAX \:>k=_Q00"=ۤ~raRPL~Wb}0d0+g W_oi8-11JZI{1eH9O\I9XHHX`_$A1Ƣ$'UNXڝ؏2{#o>ddctBI !k`J,/+ƞ_U ĭ.վio>HWnn<3s׵}k`?K&&1E. ƢE ۙ$k{CK}Ɓ}ZQ1^]swO$+j0"ozg\7!^d2ji v"Ad5mntt~7CLxn_ͻ%_:}s@Ƃ bV_I oJ7=_I@t/d  I$I "dcI$I"AI$IXA!6_I$I4AX$IdHcA1IE%@$I"A$5m6$I i, & I$pLz륱  I$Q1OcA1IEC$I$E Ij,/$I i, &k5$IdHcAAcA$I4ADƢD$I"A_~[?5gm7/B[??/<ݨ27564[[XG$IcAAX7`kiMjk޲okӎ%cÿ̿Ylk\dFoc})]_jtu7?Noimo۱;rqD\Yq474b;>؂rU-83+!~a,axÑsI9ܽ( cq%m(ᯌ{.ą ,-0/hW=3:=I]yyO].$IXAk,|x) Mw$t}stlw0k[%.vyr^߼̮z cc#>Wn畹N%mTn_mJC[ZL]yuӡԟξI긓9fz8Նav}Ru rJPO$nXALRcᑾ1mX@?" 3UbߚoSeL;õ 疄L cϕv)/VQ?Sa,mm;cusJ]MJ 0>dK] Kfܙ}PO$nXALZc ĴK$o몃_?C[;SmnBC-܍=rC|џ^+u}_G,jKk=*144`9Ԍe=zuS5}-݈m8où.J>F,+\텚$pƂ b 7m&$l날ϭt7fuLM Kw&vmVIC(g;R%c6e ..  [j3WX:0 &O @a,jDd,#>W܊X]RkDV:fנ`IdN77? z䠝SI-֖_[嵹}G$ Ad5ͽZ`k3W Z{]OKKvnԪ]ꨃpJj*kv6j]x|Ȳy$##y*M|+B3J>Z~dOkcQecT>eOƗm_+'b[x(m8|}_kTYƺ=$ɉ"Ad5PXh5<?gϳW[<]O]T[jm=Aav_vَĎ)3vEÕy5H$'4A4wmj_'<:g)H$i, }'1r~w6{N\25i!IHcA1Ib$I$D j,|.$I i, h,H$IƂ X$Id8s=m  I$Q1KcA1IA$I"AĤ5}v$I i, h,H$IƂ XH$I2\ g%ɉ`fx'Ii, h,&ֺ^˳vNYkϷ ޓf[x,i'fa=v՜#?9d<>Xvy$I "LB[gyBk7:v̮ܪFCon=P)3/>ms [_Xm"{UbOϹ^qTۺsLZRcC)9}J  o;҉ykbW?Xnt{岛e7@4mS|T~Ov?v/6P'ĝho8!gV^AWfB,jv_z}ɎflCh~}jΡRtNGU]|:M@+Jc2sAN}{=M&oo~~70DUΛ<m~m':M5mɎ?}5%QAWf١\SXr<>hZr"9ZXg2ߝIjE"IXAA>s gۜ[/|~+&u-sw\y&ƅwDexo=yWLnyշoɎ|m1Xޙm6rmݖJK%홥G0-2X1Ͼ9ۺroZ#/{~}}orw!m)loF9>^݆zsx|G7zkf4,sK0A]IԷ#7ʸ͞^3 Zt6uؔb[W#Bȅ q}0vLi-:UP̱V䶿฼ϮG=e}鍈1:2|#?bnKhḞ:7'׷gkUDž f$I%A$5( |] w4ኺYk&I B@j$]( Io9[caJXJ4ʣ 8rke*>8F$Kb}=+6Z-Hyg%u$Lkb[̓Q#UM6ĐpT::ȏ2n|o?ޑ$CZs%U~>a&+mB#.u~` g֝oMr)Gwqѣ+PBѯ3de "[}%#ŒUoB9HrƂ bޱ0b|wjiŮƙѭR3=f\w׸{L3WiU ?)6q8:xE߭w1`NvS&k09oh!c9-ӷ y\ .߄Tdž62"N2k +eJ .oя^}3.:h< wLYqLxoC1F4AXk{e;%J+o/ݙъh\7>olXZRÿ>0KFcI79D={^G lVL&ԏL;F9rK N5Y]Mo(aߏ]pMc =ƿfZmmQyDyԗs* pk {y%WBmBs_nW@?.ҷE\Ǥy g_Ux.dZ쒠Rni7+϶7X;DF:FE -{~X\S mP1줱 0+ |Vi2-{aM,D"}Ǘ>.+EۓϦ/~!M 8mky:'jŖ79I |diRw$N!qG9xwvq:S!g"?0&"iiAG=6ą}eԣ1n-cnWY}#rȨWqlfi5)aC?Jϰ!/%܎xՌNqlX?D  6}5eԊ~Iw4̌j&Oo̓omXLsZvE'۰%m]'_|U,cZM̽Kk{gtrC[LE".,/5Bu1&oO}ȭ,mzG(ShPʳ-qMȳ*]} N]F]1/V6Ԍ]o?֮{3/>/P>F:PYa0 z W$9HcA1I b24J´H2 zgϐϗHitUL3.3uGڮAW&ß>j${ɟkm,5`yqI荍{ť_/vͲˆ;1 eH4AXƃ_oMh8u픘ۍSdǣT̻^Tj9!I XAL;`FY)!am;zW2ڮsx%诨fݡLOFii$IrHcAAcA$I4AD[,KMjgOH$I4A4~YUO[tAf/2KjRӑJ{ƻ󗭖{Zя}%t%]ec%<"^_Z w8~ȅJK&+~5 }ۺKw$۟pŖ^Rgr9 |->8Lїۧ {_pxyzE_7zu5z+bTvɎ>ߎ|NSxx}p\MٹL8E;'뭉u,jIr"IcA1Y*k2x7¡JCony鋃rzjygk7YQO?ʜ#zN%<'uvoUCÇ&zsZ~uePF&-݅_oS5v)TnG"WKwyGeI6Rm'|վM8[aEQR}ݩ+4*c;}Ui>_}Aerwt`]+%/~ꝯOw~di'o5/Jh{r-o{;yu>N1nvGٛQZo<ƞC+lIEvƏr뵹GZJ18uv[~B܍1/s*O4?cܥSY쟻!~sM+i, &0@0*+GjIG$A}*(_uJN~$Ԅ[#[r}6b*>\*Mr0+BNXfLw/UIBKgdxg'K"#I/Wg4-ܖ\M-]X^ AԢښŒpv$0Pև@[mIȣMĀ\(q^ilpeee}C9I2 >zϔ5Dcr54$( &hlĂ(2wAel2:6 M4&7s}o>L:gS^biJۏfkQr*qt&g !UR>O~xf,-v-]sYvxwb4<!m ~QvC|y!d/JhZ ?{9mO\6 ֎߸'P B:`\ֽ$3CҲ3.YHm~1a·%++F{ dek{ơ&c!Ͼ#Ts)mq/[{߹%q" fKxN_*X 8D2]1L┉/u>@X&:y03̸h_*&ƢIuڰ7*1 O_\Xe`鏜(g4jB0Pڌߧl0?|X:~QJݑa*kcm_+7́׎f"MҶ0"ҐWĬCUH$cA WX^.VV،{ZddRa2C|D\䩕gm} '.CA$n 2ǣns>eKtdm#ް/6מ3.v'nQVSFv]tuB]!ι~' ytyYdW.l|aEZ RC mOp=˸zWeHxzFP/È}@SGbt,=CZN?w% X!?V0 YQCbv]8>||/O)N (_ {p|](? _[&}M$$cA d,e,N&H%*#g}X@|ᰴ)H+ILAK12^4\o9 >5~<yxɳpf :RW"cdiwIC/<mrH(Hͼb]ƂOHqoCglP#=X6\C90 ]DɄʘZ=슾]h'{b^V( p,n*4nHt L_§Sվ&_E k,k(I |VR*2'\ȼb/,;~Gn&"NuӸX?gUyUM'UV[:/,&Nw%dVBq:efm!Q6?X|<8.ޭOoGz4Wd,_Vt4hc2[-T|Kx pI7C>wPxfy<~1M_"DNID@ D"@ jl,bWI;S!31[R7$y%/OeCy@+_Sf>m3bF'ތͼj#'Ԁ* NOجڮlF;H̓1N]Na*-r&?6XIƂ@ ꬱxb5>W:+Kjot^';;6}8Xwo<b,ןVLꝸ5O< !s -זGS,ܲv ˓ O8N_@Hz4\M;v/#zݾX]&@~xy,it7YX<9spERZ"B$0KZ1XUwU۱8Û>;B\IdGRksהm q%NQg1s?\ChW%V_gDE?_fb⑕bʄae35ɯ"c1Qg:´Td,b3Uluia%Xg+(  tE.O,&N ./*Q3juL6SZvl%@zk i O>AWzW}:ŸhE8C>yÈfBgi1oy"; $m%>@ XFX^҈7= |E⛥-c lw!x-MKۖ>,۪Ƣ&Ud,n?x\煦ht iZ@b-H*L[fc{t4r20mob\wENWi"^Xc=zL_6S -5?+f_|09X`=˷k[jҎ O+'B3,MԓfBu+ s0oko +L〥m':[a;V9" @ 1cwpb*3LCx3)nzXV @hgDrL>n&Ʊ%Ƣ&AAD5f]v1mPъl6^c6 ):KgɥJg?[@y)m>=optoQ^1*S ]c&}]zW;0^ O1  Vk} t`;V)t}fYJM<X66n(lؚ52 ++C兰9D;4(V6#Dnxq;sN恠s '#vyh"`|b9c=m+ ⍁vH^n~lۤG7!6C9pi 6c29g;^h;0ۂ3Hf+@-Btys!>Kũu؝1o$׺`MEEiŒ tcM̅k`F".ekJm/$`c3UˊVd,uw E & 1x FBeǖf, ̰m@RQ{~}_r[ctF:l=m?O~8\1A h+mb-;8\ί:` ̀<^P*败j{+-!a 1KuWQMWԎ5&~tT-t+tJ<iłHƢnVĦH8rC$}3|bBAj= 0YnKeپ3Zaж~eҼ! |g+mD] 3ML4[({nU^v՟AlV]7[%k)XFek0Ql "HƂPSG}ӥ$=ǒ# Y'3EMwܣ~[QuX*]򃘞y5(1"Ō*l-mм ]j$AL$cAxcQ?%Fؠm./{㩩8Ԓn%mgWZ@ cJ n,w&ԙ{ML~Ya[¢_! Q1bȉㅯؒ#~y$j&)\7x(d#}2D"H$ TZ}IAYi)=Q|%{xxjH$d,`^1S7>:)+}rBVM>:!{|jV~[@ cA$D" * 6$lգ߻It{'颙Y|\085*5$xUIćC f(H$d,2rvIc(%i^9r3,+-Q igqj{xڠ{I{l,dB-I D"EA}¬U7L(}PiTT-+qVV|lX>\fp6hA-I D"Y%](X*{spj^{jH$d,UkIWB0O'ӫ<խMю.&jW]ʯx2D"H$cAƂ Yw2DcQZ/{ralRo,S9uq m"XD"HƂ,xkٓ}'ʕ'M٭;ES׭w>kF-F D"EJs-\t=/3?`"{|nΆaې XD"HƂۢ[Xau)z Jr'(,4x*xcqԪ "H$X`9ץuwQdMyxx'n~~q=w[\w :&lNyr9A?{ǹ]Lzslf`. gЕ(b-:/ o4G2Hw6w n͇`st_rz +Xv`7U?ʩ{ƠI_?r6X4"2D"XpIy/Սdz Ic066n``Ф6144l455P2!Ne ߷ץ/Y= gy6mYT.7|[/&KSS p2p&]ﲐYL}] p.s4\0n_o6𑵷p|ɮ3ecT\כ)Qzs5~A,EҐy7yzln|ڌ~Qc{|;eIiߕm-V¤2sW\}-So4.̪12}km@0 51}ǢҎAXIxUxǩ/z uLԡ}SSs ZuܙK,rw>ң [!N@c#ׅmq/T۾UF(:v45݁-ZOã~y(g됡Rco?hqcgSrf/v!ۈ2D"HƂ3'/5>E.g N~ ŸǨ+>cV7Xi -`2tJr׈×vt&!^#kkʁ!/ʂfu_=Ь:5d%a&-NȟIg h2CWy4W7*2~vk]\̂6|Ĵ`gmgJtXn! 1dAvrz3=e}6<|>767p{Qp+Z0MH?.kZ2+ݗ,6r;y/ca&mILʥV--zXP.Ͱ6*3H$D85:< w_OGqN: g,j ±U me`v~" :wfLIKĺ4>D>[9ИC*gXg2h̀53l;9V@XyLTd,0P0l-+>z] Z lyw~cc߃](DvYrAɚf9\za;Yo3?`LI?'-|_ Xf,$on$^niv\.3MwdmĄz3=d7@LnAF>.g32Vv72>8lUpoCߘ{7^{>IBӶL-bc7D{vL{*vҜ]^PʚH$// gL\bߒhcSk Ö f4ij`S51f,7標.phmh$aoy9^WmVo=X41ux݉Qc[Bx9 d8Bz,Bط}7.fY/uᕳV66*ش<YX-wƔ3\kC @Gmmy"cA Ԗ)|D"H|!<{Y0SVجG#z+f.- ǖ&^73[m?Y{=еhcS[ןUNُZ:lU(C7ywX3 kgÂM}vۜdlUѶ6sy@NGˀv;M<YfT0DaJ~$`laH;=wwֲV(U;:RV$-)7@ 06q#~=ӷ+EmK׸>d/``Pf']iwkm~6aS:/$V9^W;~6_:͡a'jʈQ[:Fūl?)9&~1\ӷO=ue㇯:6p~Ï{}>Z}t }Y"^+W̺GO @  mޑI=E@ B;{q¥;;z"@ ZxqՎNTN!@ e \_.>=< S@ j8ȸʹ>v!cE@ @ @ @ @ @ ^? }9@IENDB`lens-5.2.3/images/overview.png0000644000000000000000000072277407346545000014517 0ustar0000000000000000PNG  IHDR @AIDATx|ud{' 54A:*'' 9N=wv E k I(@znv߸}=w34DA[` lPB[` lPB[` lPbDYW.K`)X!)@[UԒZC` -0 @(` -0 @(` -0#"@ȜݏFFn^^>(ooȯ_Hi/jԚaO;QRXr=Q#c~e dhh)Z%VN˞9g@ g7hh45C ++.d۪mN`)X2& FNðn\%&͜Wwc?jkj/K^YB΋Kn)l_莣gNx@1*@D\dB:{Gs{N&mfSoYLL{1‛10gxQ}EY &f&s_R*17ELӟ}i=[ $ (x>A>>p}2zR(7~sVr֥ӗt~vNv&&C ŔuK[&CL90I:8.**Ľ[;8TWUGSRS)tZz`% gRKIQ"aD\nb_+M!bZ8Tjt.:* )+uS22YN^lm?i|IqI&lB``lW/Xsw?|rc/G ."#--d2Ҹe ,]¹ }Uk }\Ù|&|n B<#^ %k7o t>]qe2*ciAgMOiGqX{7YY5W`/qJ-*4(g~4]O۸٬zxvꞢ` hAcO6}J&c}!ㆈad (Z+n_u+:Zz_Z:5m3y}پj{\dfմ0Y'<ϱX MgH(),!vFX~rWըNL O\Њ~2S99vʁwtml}BhFII#Uj~ۉœBqP(?֏rVV\?hHhaelmTHl55{Yj3 3b\oFD^;dxrJ@7ZS]V]VXUbnǿN|kWд #uϬ8 9+g'Hܹ+-={rᗕ|鞗|+IqI5U5|w, ? ,xleڰk.1}LL2OPLYzb~23rsy|i0Y3@֋UKqR9:UHQSblblfs/5MQF$)%%9(RdSiRZ:1´Ki..0KCwH&%wɅf ]g¨Ўu2j-9ى[ ~=ō`&'0 @(` -0 @(` -0 @(` -0 @(1":.EJHh=W\2'O䉶QI4)M-0T*͕rɰKI2$Oqy' Sʬ* $+'ɉ` J* XH-H mS-UK`vX,IE*nRR'yȓvee}F!F 3΁amerYw. <x7R#3T;(hSkOXjMGEDL&3Keд UKW|y7V.jN$|uxSRH۬L} Z7k o9>dÕxgG^MWeag1Y55 .$&[VKꖞj*K*c$O?u}LZ7Ϲ=N9~:ݱ\Y[]}ߞ~Ƭ,ݶ1I2kR4|Q[7O; c=8qdّA=d2mI]MEQfE"m1Ewٴ?-+م,-9s"fkLΩS&L:DX%s/yEo>^J{ұKOq{l\m"%{@tbt=7϶G8'>O{~)}F"KbXanlo^YGȳɞ vJĆ9wK_s{O=y.ӹHx%23021)i&#˧0ERگ0PL?r=M cew2\X}A;>홵[(C7ޜ1r MؖQ\N{%Dsws[?[ub3ܺp O'~ҽPL?=1+C{#d>G=J\djC#.غ}zX^X>ٱDp-*/`7nAӂ ywݳ/}Mt~v޲ҹm1#|N Sǿ?^{iz %vb5cYz6F)-mڐrZxd;t}_ߦ8f%w,yn,%S=> Y;C_x/M/m<=bG{r٤drhV`Xhufuc+ڦW65ݾvZQT/=D t~ۅh BTuzz+ߛmս5ow3?)˗Z*F_/N,kRD&8L_0ԯ^jnBn׈]tu5ube/W?4[^o~msIL=xL7l)͕/x߭rV<)~[wې{C<x=eye[ofc-uww=N<Љ }?nΓ[1R㰁HIwa筚'2%jA#џvKt̍fqGUnՁl,+YzXpx0QܺKF=&v&τUm`h7!;SH_֤[uUeUJl^=d謡<V_-f;;f}6a %e6ZY]1WPQ<>5{KBKn_pL)zw xňEs?Mzw-'[?sO[?%獔FMo{3ăkmG.}]1ZZ7FhڐzХ??5ĸؾnh)1+ R *+Jԉ[G1rȁ3h?zhѯ:=ŘJ%|hXTu) jy+ %M,ML-MŜwsg]m]NIa=lk>kS6Fۛa#k~VV7Z)%\[6΁9)UUg3Fgꋮ{96~n﹟i#m˂-b$^CO'iвZG^zɧ~,shO1'\o~.ߞ:ڧ֞}Ao?maŻzPz2«=ǘW*t t;吚1{D䀟9b}GV'O|ln qU̜ͦ6ڋǞ:;AL=q`1-#_9 tibwO&4Zܤ?mĚQ;[IVS9G!޺K٘,9h/#K)w~ [cSש/#ת9r+'+=nKΧj*jRR./o.UyD's#׮94ZNӆTCr^^R 5W}}ḥcC Ↄ_t{kvj'j}&g3 R Jto1?S !։#؃mV6^n_b\~'8raӵ۾ǙfzzZv\;ߧĽO]ԪjUqF]#6Tn5ϵ%w]_QkM ~׫ c9Zk?\qߡ'vf-{p6k]XȽ!ݷ,nO܆7<ي= fiuʹ+,;2rzO8\Ͻ><޷7}OzvOkv6۾G*s+lu۶״8afsͩhcW--2Ugnj~i]L."7uX: SKS1flr.<)^uziAc+EZڄU5ݡu^ZKKzEaVY~ĩ/VMYnY崴~˵vvb%l;X`J+ 9޿^[4t8-m Md^YͺiM]8"/%X7kbklQ¸~P]^tδ4RWTTZe9=av|vӧ{:ּ{Fzb}s7_D?7v1?DK;GKG9͑)d\(z:=6S S>qBf]'6"mMIbI$ݏc+E;4T[nC>\!:N.%2j߮ꡩ/liuN޲;GܧJ?0vg2z-FlY7vrdaZ7X{"bZ ړc5G='t.j뛷}]k5ځL~~r .D/m6g g~4]O۸٬zxvvdŋ~8 kv3ԔלK5Ki,H.c ;HkM=_|mc8rjW D@chuյ)~,ndbdfmWk*kt3VR=H $KJGi|Mt9i賡u՗0YzZ՟:KaŒ}C][Ӏ𖮿QS^s냺g+*|y@{ۧEUWj7Gn$WU]K F ׄ܄\E/цu 衧쪱t EEGuu FJL<77r`gu߄-](͕c9v?FɭO:vb_o_s{ε~9yy;1J3ܵD;tܶph<lٿ }Zף^;ZדD&ԛ]KklUt\7,,jSTH쁯An} z^u-㇖baV/]YK@[Q@WcjeZSQc?wǦg1{-/RVxΧDlYƭ$!4AѤŤu*K*uZU%U⾮ϊ2@UU{)W~x'֞P+?0\OMCӅJP~찮f ll_#sO`ǚYe#UyUꋺrBsD{ΏVYC<6aG2e\wGОn֨5k\SSR^X~c 8%PtGW//[Mʪ$QRY/.Z<~qӿ^9wX?^=1NKicj쪱t:b*.P򼤼M/m'>=bk21+G-+a-iCTժOʪҪŠ´EoV+=Mv0q;SωN.ړb8>PE,韻T3'ǟ^۬^Wk}]_<'huAUKgS>321zbJFmN9u'gҮڪڦ+e<y~?8ܞO|2 UtxS?}LLV[yw-%* g~;+q~a-RZ(.k,ԝb+>SI_ 7QrWe1bLLdD5^ӼS9s"F\*̮.z/hߕVV6}m-3d&nL:sFyk-E!5\*oPawk?1ɵ'FujQF$,#A3ΰ  TWf`!6dl .ĒWWKM/oϖ 01@l1bībMxW}uu:eeyy:EͯmNNOW(C yKe{f'[ؒ!Gov˂-Q} g621OwK?u1's?iF Ilw[RN3;l9ա#ˎ{>ٳӽVV^jQ1YĚ"3[3mu)fK+L+aG*ŀź @ɓN 9Ě]|`m ? u<ۼT֟|(PEVz vnaE{Ĝb>}tmEW'm~u5u}.2gќio9гheGV;ީ8cGkO"^pAӃcG [V=!'h1ߋ{I?o"ԨU?hj̏gZ9YJ%W, D,ѶRjzmKH~;1_c6$kY_0 Ehh)Z%Zz\*n+,P)H-(+su64m4OMeM^Bc/Gr FSQpa$"t<,eVT֙٘H,-Gh99N`UdVhOUZVWekcli|٬~y'$虠 V~bKȨp۵VKrtlM/Ӟ!1L!HJyg;O=[[=jX[UkljܚVҊl=lry+?^+oRoyYFtʧ{ּQh&܎cͯmĸ*yJJa][W'TVFSb>\ܾ ֌tWNa()yސ?y6ۛ]KklȰBֈ/o<,Km^J+Uv|ZhuA2~h.d(^tFD@ףw{OR)^CK&ݨjΥQ+iKh6FVk lFFֽvbK7LV[:?hp'\ҡ>C>it.ѩ74c4 XeGv(nr#9siX޴>3$Vtۗ¨lٺۦRov-#ëX#G z\i.-QUԟà(2qVh~N3{*7D\:vY.H)twћΈ-3)M*=x1.RA,(n_w?E&iԚI))nxªOYgٽ R lmxͮ$SS](ikf3` L{MQn̥YϐOc#%AZ|RL.;M}wsUyd#sێפ@;Й( Nu]ZЖɨvMTkuUTkf6 -0 @(` -0 @(` -0 @(1"s{)$D܊+ +j+kkoX{32vqnnvv2$ɓ<;sEJ.TdUTfU:UNH SR[z[YxZ[IV'gʊ*H)MTP˪E{Bndj$ZLinonjm>ή ֜$]@MeM|>8XۀKsJtm뭫S(ݖ\il%Zhö.~.::)98<ɓ<=]AMEMK.%KrD+gg7[[2L{DA*+B׾VigTޣz{KK$O40U*xNlqrDc+ckks7s  ǡ -#S#I.Uio55ڢⵯ50r:ey6TY,Zz*UUmz8rvѿGSkSm+521RשTYWVU,{1W׺K4Qq$Ot^&tO\Z#7;v yW+WTipMyMIv}G̳K)d}Frs%d I3OgtdbF MT-=[.Iqn}~yUӮ5ݮ ,/(ϊ<y.S&3xzp#dB4Xnee)R&gϨp"nvϒnцeVT-.:W$ڇ0g^޷{;;ܨv$)%eOIi9RF^h4I'blI;&S܃#[YYR gzLhB/fXL4hjumBeUW}N%Y%&V&-^:8+Wڜ 9bϕt2I4ɵb4=o2N O$φ`cɸm;ߋ韛2kY_.-FlUUE]($pr`д)vv^E\szbWבsG=¶m׍:0Cz/ڲڄ W:ele>kK?BuQumɩ;R+2+lm;עۡ )M >T z:V*n>c|L-M{uV4ժƦ@ yv[ yպ$,[;z}B0Ln'r/piͥ^3uڡ b~vׇٸ {`؈# pn6ʚmb9댉ɘGLzfM yv^8%]l3ImӾ-x3"qCe3A}MLnHnu5uɛc帎v`)hZ+Mt;;NO~k3RIv|_yA#6ձc{-<;i0*QF{b[ۍ0鸥&{ra8qygC`l$ )*-ݺ`롥zq+ 9Fo⑋;=߭f~aC-$'{n]BhYCoﭞ=;Bڵյ?ZV8Ib 2j gSY~dժIN8Kˎ }VV3ޟ2+z#]I n?S(Z`wG?^i9g\.h!?p~ RONzv780Cy l⾋ {.(퐾s䲎[ƁO=$>Dqڡu-*Z:V;C;Zuuaaz6 3gN'0"Ollu-Dlg~d'>3ooMi9h4oxaëն\3IטgVUqC);R y+ܨ#,.0K/;vPĜ?p~ܕ55/C:|sCW=/31kȳ CRשw}k­=CznK}<%2Elk w/nN8qygC7`{l… IɖՒgk<)mKNcƊL&=aq{,be߶c$dm)Y'yv<=9o)e-;xnNC|Iߛ~rIK/K\$|+*Jʥv}kC+'?S=CzvL9΁sl߱Z:2@)!W3 ]:.}Ѫ`7ߤVmzeSiA 2N`E^;ߋ韛2$kY_.-:l_s_ߟq4Vknk>|𚊚/ndu:0C.y^cn\}.#]>צfbk;WU 1}{Cv/QըV_=w}x׬OgXt] {`X֘ԧ-W!' ,b'?)H-xf3Cfi[oxrE|{i]Ik[Vw)Hlp-GGWY9 sWU);W 2,`RK_M/o*J+ tUvfȓ<+kTq+u<&y9r^ڷ n=Kcw>#ft{SK᳇g__{@ّ\xǖϵ}~>N>߇{e{K2N`E^6lu-Dע  ~r]Y¸) wkiNiԠֿ̐'ycm-{<YPQAPq+ZZuUU[Q"و2~ ! qˑqO>I޹ jm77]W]]wgkUWY[JH Fs$N܂ ;)iTcGazum:4PSa9+H-}⻋%>'fSSo?}H@Hɰ#Kw'߅P` @rR,*{WNvOR|3q6(^rk[H<UQg#~#7g2l3Ӟo"*yv{| &L6WNyO1{2M䩘yL ȈX`f3Xӡõ.]@?.+pVINuR rL׳k6 ea1nn'?IF?.<*Olk [M/!(?G>JU[9-Loli^ O~}TUYn|^Jf)4mÛB\M> ;6y*o O*e;Mǥ-$oNg3W' OrYPpuMB7* +'lQy>]r 旛z۵m#7G 2K>uKkn~qE䩤y=ت7rC1{dEg G?.<'ʵ}-&ou満u'S!!y< " +)"hZ>40o `zO&y"ϖgX==cCjbq03<']guPzhh=:y*] gbߧ׌o_ԌWǢ߅<d-)IJJ&;~d?޽yg`k+ RqVNm̃05PEMETJ8y"ϖgeV*ިOC5"aQYQYkدQjjShU<+O@-Kݲ2>~,]y'Olk JPuE<>q..SYdcY4'Av_.][Cn9Lt÷)gS'K`0q_g2o4ʢ>xFl9FHL:өĜ4IC}uՉi'ߕwe].,꿺?q7Tn5h]Sy!K e5/N]o~eKL"E4f}^zEwodA1M~D-$Olk 49Q#H_.M'xO'9y:|w|ZJ(L|D $ Ms*+'!5˶1b{M||rو쒅RiTNK Iqv*LE]E!yQ[m-5 5'l<̪*-O5Foq+#v_l r62?F1ivk𭼐R@4=>dxT=6'!d2LPTW<֌t׺oS^O 8Q 箾P,t+H/Д_;oho(g*n@R;mlL:L"Ri~lbJ ~8qRpGGoexYM٘SAȳiqUJKd[_*~؊0ժ8,M.521iDnU ñt\tarbs}ޚ6jjޛ6k򎄉IbpLK E͌I̭PV*ZX\y<15fڙ2]]e,wvܱ:3誑QEa1E$nvx{|{Yﶈ}t~D-'Olk J[D(>9֌p\) j9]ک>'ē js8QԳօF}ybMP-:O<:^d 4]fTxFhӚH J 1Z&Zc[dѦ:p콬w^jQ>S|39q9eyeAS44rrdWUSjo=s#}< Y3enQۣM［FC\QU^IצwqpEj:jMP)T c>JD]K]=+=\ysb劎& ŕ%%}Ewiit#z#p뾭tc n_*qMT`0DeF5Fu^tӫl|JO%BS|좯GN-P) |.xm+oyz,~Lvy<)to;"d*8XU;)dm^}̟{<5*cijq#IoR.$2)V 8Ͷ^y*] gjg?26S)//%},͊jA@-^Ã7۰>z/[~Drg>R@HAM:Gk jn&\RQP}TkhD5iu6hr'w>>xQVt9~o9=M, ?7 }|q)]z|?`H <4 y<';>"BL(ʺU@]W=f~3ɭ|G86r7_y-qƷxi멻r$#io_M Kv˷S9ϢB >䌓gMzCW]Kݑ[}s ^c>R"ⵣeX'g>+ @ 6]rAUsZ#vFjGj]s:L^h 톷{A{,7Cx|]>/>1?,7{tS>o9в00|jף]?DT%r#!1$dɴkASY?/4傢|mv}w}V#LHPKkhjP($Rlv3v6vsDʘ'Kql{)5z9 .PiTwy3s豃3Oy)RPCR -bzN;-٥:ql+~mN7@?y"ϖ'ʵ}Ň/DEN~s7)"ACBTTTb>QSSR ͆xޜ3hV _[ݷ(;x@X]^]YT[mmjFkᭅ컰q1mc:coF]lgyc jة04?맦?$ wemk y"ϖ'AXl3N oEVEwA:.:DnrnEfEUn뇃=v؊0F K<)ۙWt*ɴ)U(dn SYTwOsO=jFWA6νmm^z04ė?$L N JLzT]V}kPSS|:t䩤y]ٗX>蹰gC~&{[p8U%U|.ĿZQx{wPh>t˻-֦S{ݰv"/9w!O)<}V3(>P(D P?5G>ӫ'6Ī$`0tPt -z{_8">{ RE<^s?o?| ?SiR ŒIo~}cԷ$̈d<\y6]neeDn:'(UUT*C!ņ#cGjXk4\'O9OG'vܹ95TAzoe2/] rvqŠ?~IT[FO) vDsg luʎaĎR9 w!O)΍F'%}}1ϟbX.$Ƭ/hpTm*/^i W~zZ^Y)NN5UMZZZT}Ze}h6T:uۻoN諒e,zVz q4l3&=Jʷ5 D&O `ݯFmr[&440Kga9r"Gtܱ>Zdުg矵hmblꅕrbsV?[<:O3//<"C$DEQl6.QBL'nEkY;%*fRVɔbikkM8N ]}x7+gC@cr0 Oy/w/xYpk->J[EvŵטL?|#@Sg3s]}v-1R#&ZҫӸNȳ rftɇGfil" OL?}5~DM'ʵ}E&v$H QÚ(O'K~uN(JM:'~:dOH8 ++V*I z@>h䡸;qsꠤe蹃- ZiԀ}Id3y"OS<ݑw3dߤVY~52<0hڡ+ɕA蹙|RԀ0ߥof n,PUS_^pS;?0E'Y蟡S?dSߝzz싳]]'߅<87Dl>Eb\@g*[~n\t5***rbXQuԌOjt:8@K &.#}5vXiJIJhʁ^eհ) DR̳1 {ciw{m>s&Rl"R/KgFsyik;-7/uV1{Hy=9S통tlC\3_QTqh7!of=mE~]ysV >` H(Zͮ@Fj]^3 Sh4QMhfָZUuZ)EW^pn÷g}A,uNOcj09 ASZy6>"^nx2k4Mbń.5ktCPD1e =*c FuP++O}wE;FXCA'YƒY8;AiN~xa.;߹m-'߅<8l3 -El>QSDU'+ZW_~^QŪ^V_QTYP.2*y~NOlN(|[??p@ "by"O)ޜ{L}_qgcϭmykڶ_ߞL!KȨ [z.菠ۏ7h x3N#SYAJ'ٻw~=d {4fG |./nlaꩩZZxBS\l3 -p8UUU(ȧC:W_}DbEӫVhdZE(.>1DXi>,u:f:SNL`-by"F)*+gtc^zrK535~ eEdZw7ϩr~ef*M)TZpqň#:01j:jy4DyC?.<5UV>` H(SʧUTTOh4Z3QӉ: p?uH鰋/VUYާž,-,>?~ļ]ٷϲ>t&QS<-tRj ]ZrFO|:ψyX̍ƤɮȺ /~x P7Fl:<+O7lb8, y0%&ӧC?.<5aRl/(7lQ$l@kJDTW\|JT)%R#XVĐNc()l8U;v[ tѥ碞M2#[S=_2¯ D!xUQQۢ 'EMy9N'H|ʜJI~j*v("wo]\uE {K{{OJ g(Kοn:ZT*^ݡg2jRBLTWWW+DTY,ȹ`KE^ dp%.VVbrIIQW^0вe);먦&) DQn|?RZb@bL&r%qg"wj\+yCĔ<=hqFF݉jc'c2}44F P_x YLy*{ zᭅ2v‰nDsrjJ_gEg }ai\'>w/@p~{ in6O@ySij,E( @\UUUYYYMUxkT*UMMM]]ӡhDD|ӫă`bj>8jieۖ4++RBRބI~̩t0>h/fS(y#OO9V]r6%Jz\⪁Qg##5~uW]\.]nHn~h~\^O]j(;]W&i"MXQy y,mUOU2ՙ|~h!o޾|Kc;vo? ORmX)Vʭh%DM%*q.ҩDCuYEMEy6]ʻRnwҩV&&ت\?P/f6Z.B Oc2{/ty6an2Ns3gKSJ+s+UޑB0 V::PCE+y#tمW#jQFQi~y`1L &jdlԲ%ŐsQ< ~򛎅Q+# MsCNO3~*_:++:+7C7 /1$>>5]5m3mcĞ͌6x}w/7hh4~.2L~ `Kύ- @DW%%%5ZWECQU Sq(T4^3S}"ZϑO**<6O Йtх2RSԊ鯹A- ^&z'<(QRԕy"ah0)|8VuQ5]P[ą Pvs2)D,O2r*MTXgkRg/yBzvٱ :OheʸUv[2N<6QBh U&.i-|wݿb]K潎$w?K?1Oq?wG;oPf}8}FK<mzz6gC@TWW|T3R KK隚ZZZ#ږuUbԐ?H".τ?=tyZ&ZSBṥz9ժBQQp,gOM .G^^|6bD i$uSvOW;TSwz.9bF>]gG\xB^2:l]|gK X5]5Al{:7(O1 oke'3*8#J-h*++F0f~7QUqѐ}λ7N>cAHCN}vuB["UU&; Y^j?e;K!,Q@0pЏq/3`϶.Z T-ڦںVoBߠ`***XJH-@(؂F(եa3RTDCy6mj&~:Bu<1Gm:iHsi%>nH**wՙ[d.Dh~Rst6\_}[MW2|Kz+Rj.xw޹  Yq޶)!)ȡT ؛73|H& JJJ|}u>&FFFNNNqQIVACCi@~oUHC[YT9B[#Y,ǩBָܫ?^ciH#KrJ# h*|cӍwEٗʘsyށ{w޵6fX5xE(@G RY\b!4e-G lAS/Q VHEEY,GĈgXeqnzkNHCJrKnnwe_-c-P9~ x_pٻ? DResoef] ]MBT5)>cLΞ;-5q6Z,KC_ATq>Dɥdֈ$B >1WEİD(܋b}K ;v(f#:-&@* ʏO8nX;i8L\ZsIMWވB/7TSq(d=6FR/Da2_{wر,xEO MAVTU`Kr)!)*j8$H[`l6GSPP >,**#1ʰ@P# Yxm蟡NOcH**yZ2wc boU?D!27CAhZ"*j*g׎;VԵAHT:MțfeGjG8"H[qQmVYYgb𑾾>1 EY8)!(}eo/; e( 8BRqg>we_Dw+͸ZK\xsᶮvݽru=uw[okȡA*+YI]xo5J@B(iYAAAANNNnnnۈnL ӪU+UHTƫl4d!⟈ɫW# -?LJd4(z oU?55rvg?_pxB?KƂ_}~;pKp$K;onWTt,td$ V]Z! ꜏s|>/lmmEㆆ6LFxM#BQDOJΑGll25."{5^x񅪩:YN=9hRH*ڄyoPe\س 痝s4ߖڦ o-؄cߝN+]?ۖ԰T>.;+-Efnfx_ GɆFx_@`<%[ʇfgggeeeT3B(**G ڶmkXBRiGj3 7TWsԈble;C6 A;@AjAquIL"ȳr3r{E:cKg;5ǁjAIgC mX#YeHe>񾠞{mJ!wYӓgO! 1t%@`KAq8̏D#JLMMlmm}}} -_T*~P^:r鷋ZK&onumSm!kZzMB 'ÑOM(@Epjia Lۘzo;Woh꯬LCD5:Y̐CH [MI((==f'///qennnQ݉aU### kars60|p!~HCF.{ioD!'N<:JÏdK(Z˻wǞTŧ] ñ :y&z>e&=;+*S&&VZlKpv۷vmG n=`K211jn82H>@=NN 322l6q:nnnniiiaaѫW/)POOH [3fwt&*6$qǫuBv3/ iٻzxDrǠ?{9?8% :43*^SUk!tp)/) /,qyB/_YZ"  <7#iiiԬ[jիW/b# d'#N0U,:pj7DVtֳfA"bW7x`{W{!QQAv]ۅ:AnޕGVMb5}C '{enˬ]spwiqPUE>^-~4 V,)))11&G`XZZF@SyvYWۺ"  9*d.ͬpܙgJJg2 QH+~o׭/TrK̽2@ z3n]ѷ&Paص7W t uE7>՜UV! h l OMMOHH rss۷jwҤIvvvU @?C{ 9iHUIե5f'Djx˯]ג%[&oXJG#ȇ@ 8?l ~as<{" h lՁ&%%~ph4SN&L#SSS|~#A[wx+?] ~($syeζ\ယT޳M6HҚKbhZVTv(>JڐlPJgNϻ@ Xfua=t4dX[?HZ LZ1IŚ s| 5ƌ3(Tֿb܁q?xw~Z!!2 747D ~7ܢQZj 2#H$+MPs+؊{LMM}}},Y`0Zo\;qm]HCvnrh’SLExJ\…K.ݿNZo߾X-[3fł Lm[jB2~3Fn+v۸ <Q-<>$Γ;#Їnzp^KzYj!KKDl}`F&qbe +ت:ӧ޽3x^zX,NٻzoZ|ک :ҐA!7BhHCeG79o$T5bpn߹UVk# xt[{) F2XP통 \ޒZ&& ]vAIB *nS ,0555kիWsrr=:h Tk@!vZwҐvۯ}HC2qxSVOAsNֶLQHP(ܵlW_/>^Hd뙯2;C4$o'$>Ll9* >lHz8uÄ ث#rPÇ;::޻woӦM999'Nׯ~ ~' D2utѲE! ɼ{jI+'ij! z|O\cAIS^&,چ?\ZDׇnjl4$OW["ۻ'E`b#l5HVjVfJ& @Z3fedd\r׳gĚO u֩i޿iTzbNe1kY4QݱxG=={" `W;d{W{}'w}^wp?!YZ Y^6)jyN][b" TcwvG  ]Cׯaaad2 >ئc#7ݬ4djܭ66#@IOLx⬟gRYk_yy~ñ_,lDvqŒI'᫁Frh;-dy ԸT!FFȡABnxytDR>YM z-090%iʂƠNqjU_<39{vٜs@3SM!IBDG!QHnT޷WH{4iҥKϟ?j/8d~] +$KE9gB`N**/>x`7o7!W!.:B ڻj椕"]WHw좱d᝜yuޓTx0FY;YNz<# aB*J+:([CH$ ."~$?/X`GXP?OY(?Qڡq؜[ ^_{__D!S^_=quE8老<~_0THd斛c4Pjtj]y̭涄oc/)$ViQ˗O\bV>h㙍zHC_%[k#j = *4jᶅBB5Ґ틶{z Rļn y>Ґu*;%,];l}US"6HP~8Hl  ܹɓ3gĺ{giȔP(4kSNmL4$gTO!S]l2D!-tRDvS=DҥevX{mm6SE 6U;KQ Bw}w{Xꥲr5ݧ4d-``\Dܚkd2Ґssn(dt諾#玴wGRb^{A흑ԓO&M8{԰f660=!+Syy[z+FyvD E G(Θ1ĉÆ Zz2gKiQ/~Pl{wޱǢFbee:x<^P Bٳ`}@=%mu>} y=qhef3PE$SBpܭnn&FٵlTFdCnľF:頢УfN(تSNZ)rWO^wQt5qŋ;vܹbe@=q9Gkm7o%nwC۳rٰYL] d2iHEDPĽ\BgБgm:xMB2`1|><7%E|cKK { DՔ[֭ۻwӧv,ّ&4dئc-߳QHUȫ.ܶFCW>|pw!|>TP [aRBRFjK96[INI潘No1ZӲMQU_>@`k֭6m:rȈ#_~֚٘! YKK 0HC2Bpҝ=4djߺ}d2hBZ.dD2.gk iȁ@{7ŴrVssrk)/+5@2H_ȑ#Vڳgɓ*1;5ٺM6.' Dǚ?*?@ So ;HCn{9;_{/fFrV7YǩGWyIWgtAt 3eĖ9[ (yl=zh̘13f>Ry4i..07owSؕF>xѻ!ѩȹ#vZHzLiWhSޝŴj}QB=d߲teϞ=[J)hCHV!i/SM4ӝ뢙13}޼59s:9O3Ϝ"TSUqգW328! vy6D.{iYiNb&!!!QQՔj~::(Js B$-=ߨUԄ脡" w(6Zg}aaZjoo?7\-JOO` &ҧ砞cfAQ?;l![WVG靧&󩶺J,7e҂`+?.*..7napp0 '=NV^HF Ȣ6655~ MUQ7eZ^(ZԌ3r܈h1vX32JjJBBBC' UTI~Lk氠0S S?2)s]Ge ipA{/)-4~,YnKaYQˍ7_{yQl ؿtSD}#9BN 6/DZǬg܈5;tu=f^75ϋ?WDEO.&.<5md c<$^4 {S,b҂ҧOKKLї[WbᱪZ')/.t󑐰巟Aĥ.x]]ĉVxM Y7R{vVو23 \DtZB6;F,t9w_-@d2]JHm9ipA-v#g8v m^Ge/*&48'!*!\%p֑=>W;[6n4o&gDgL5Q)VNzG`'1ۆ@{-l :܍stjM6|*!h((Wzqv 3f-c8'HqRfKkKb Qע_y8mǺBkĘę&3g: 9TA^lN'Bn %[l*w~͂ UTT:`29os+`5Z#m)çWTUaICN'q!0n>ކ> 1"YuiďIO|ʻr[hSN{NI raõյlBKm6ip{Y_<n(M6_36LC}/_hCkX'bAxA` X5c22Qעwz"& )U;WW&w܁.%#EYṂNyl-} {ZZ[1*pHJ|P˛^Zߵ6kl^}($ukᖅwQM,(ڱcիWCBB:u%=9V{4/=y%'oY_5 z>}[XWTTATQUQAE[6"iQףW! .HOiJjJH>s;-1mþ |Jz52(Ί +*s ZW\d܇OpYh4u#l1= t?w|HzemuL&u u f-81~xM/c^q\^Sl u {&/>(5;ti.lҹeZiA)Pum۶|b61 Pbn`N}% M~Z.$$4oӼXg ;uS}lq>b䛧nLlJlMCf3G(á ޾}kkkk7d L-L{?XGNI|efM)(3-رhvz Fv*-rl h;NiGyyua:Tsii أ( 󄅅/~-x6YW͒.$Db?śS,xSnj1jj- N5xwplnd2wdg鯢c>ZBh]qmrʔ)=zؿ?S h>s;#9[ >W3&zeyvj6O޿S0ooC|qCAEipAۜ@@;wvzoKϻxrJHs΄%F':wn9L-wpHCMCg vHL^44uQ?߽WVD?C-=-^O/qƗKGb.KTLtO\0eyЦ&bKo>dҩ>hH˽)Ղ:d)p ϟ_]]"**Ywy%5ּ|eycC+:+)-٤[>nMzIgҩsnQ&WT!.SR3_gI[~ej%bXw[5E\ă\;i.]ut J9e߆}+# vٷqnRDƱNcPPV=sCfML`xxpihr()6eIH )_t격222~73?>BoaeWg1J]GxuLnZf~1m_:wWPХ\^z_&-+=z&lmZ^YxEp;F,mGop_X^ǽy&=疸-)|_ryk|P+?,hAtvkf&nUVm]҂Rvj?^7 .$I#ѿݚLJHņǞO:`~;{D`7=4̞3tޏ4~ n7r$dRg;?TQ=" #S'sŶkr"=ZjKܖجA?pl۱YSm;zzjҤgϞAGG M &O}m=6GF^>/=O^I^wWZ}[VAt2\QR!&.Flew?*|_Hl82x=e[ fȑ7o$"""]ts5`K$:?)olnC׸/vxftLyqZs켆Lj-6 \[^DVWYpÑG L j6mZ4k0茲2| RN,5EkW2Uk )HJ223uleLnQRgivsپE;;Ơ teWx{كBz"41:5UTLiN-vYBC PVX(إ Ď ,4@" _K^dim)$wU{\:O8yy 7#٩çi @%ٍem-?[AAA/_&.UTT.ƆFNW# (ToYf5Fk.Fq쪝4t01a>N{#$1/Zluu:Mn0LT_C6WRFR]GQjB틷a9/B sJ߯^zݺu#GDm)ӹȢd^v^jv;Ek< s#нCs bw~+ܻ|/Nl@L.pA&FgMQ3F ̃"zJjJa&QGLcw/1m`t{XPoH ?&pB/// ᵇ/;wǴ\\rܝ't@qך]֖,! ιBVJK >ifj%u]V0pA= RBUeea^kimW;簳k߾ _aK"GDFI`jVٵvuAi)pO 9㣠(;g&g\D)^amf[%+5V)+# \yך]ӖMܝltdדd2nx{퇗Fo(QW3ȖFuEqE=L&3uf'Nhι;}12pO ;|';uC\KVAvDL&sNކSMEGBJb/+۔|*9 s֋4;"}" Gv0(\}@)cQR{;֧O5U5]zvA5Q7~=zw^L 8mۄy&̟4&,(ѭG nHOq:$,,48ᵇw pFGAUa鶥#u~Q0_m3Z\B橛Xdd򔈙əBB а+!*l챈7O*566:88̜9_~~Nw鬨f5Ev5sLӡH5(eX=ð(ʊJޓN2e417b\`Z^{_HnIHI7kL&Sr[1#9C[_%ι;]ͺv茱~`+ Ǐ;wDKn=}q t_䮬k%h}ICO,~zD.U|WZ-2f4KŅ#G 5u cQPQ,l239Ig4joxx!#}jkk=<>4nuH:j$5=^PB*)T]UUU1p,(5MMMl~RJ'OTW8; ^-&.aD.*R3G[L@5=XV,-%e$oDAYmĴ4ⲫiWoQ(GY$H)ڂ_.:tFGvo;,o^qfY4Z#+5ٕ^+յՑܻ|[Oldlo>Z#mӁM}lk# ~'.!>~L&t*,_Y^6bzb"G:QZVmmݻWZgznطIg5Y)YGngiFSSROކ+{l(smVPQ@5X;QV Q |((唶y&523BK0KkK ) Dk[T*u~RYQ9[---4Hsbdf4ahG}0e^RR0?Rk>r%n>g׾w{D! ͍\G!,O26x M ђ&;e:C?1ٽ{ڪ 8MMM.]d;# n:rSΧgƨJ>;8SNHCƒcnƸrÔlt@n͈R@I MXi(bQ|=B,Iis¼®]ьi:Q ']p?}[FNipG/woطA6h%ފj]# )/]k iKBtBѐM7))! GI)J?g2fhp}re,JOL'.Q-q'ㅄPɓ' 5 Q ;^gp6mVF+ݽtѭG..HLەՕWyBRK%R:i蘙cpxdd12$ҒlF߇ #́6X(ֳ{ 0"A?[jΛO(p2lʰV4iך]..(5~SLOsRbt⎳;PF{7쭣m9QjȲ!BX-y|p SSS9[$\O" nzxaXP[1BY,J^QpH^z:/֧`ȸǯ;vTVWFeчM&( 2ggw->6;%bTءRFhsέXy8TbLeo4K=[ MZiᎇц9NoUX".Jb3FZZ[" ಂY.(䅓#/DKJK OmSJ)ͻ~x? ._L̙?z۱ǩ0LnrJrm@TKZ5rȡPy)'=NqvLFƏAgl>Q= xudWD!WWSu-O_JVJ%6Dʍ7Fٌt'ِ@+++EEE 0Kki|N-6N*jGU~zݥzjwYOL_2ʖ[Os{ H@;7rH!!!!ԔtͱKHRk֫N&%z%Mk m-%J_g$eH::FfF4nwv xO0bH7o\b0@Iɩk)}JT_Ue?@_:B)=VFFӧO.\l!"}#O:yrI&:чouZF4.xsiͥ 8:hH\E"nܐ7L?rޫǯ.a%5% s]͆X5i s 3WU Dm₉/(Pď;/!%PЦWJ| CVP}OқN&."b/7o>spu '1$qѶǙt|(7/dcHcm#r=ŋ544,-13QlmtO?)L O>ggE%E AIqzL&^I|=rrHkjg9sަyHk/>hqs! ٳ~GHg%]-rimZ#{/Z[[ #,#)/i2لMWJ P"$,+i#v2/snݟK?8'pZ!J31׎]s>N iKxpndep_qFqFtृ#GͧЈK<Co 4ARHZ#m윱Gzmu_y&(q:YJJKJHJ?l$||֠oFQJ#׏|ɉ' Wz?iii'N@R2skY}~}u}JxJQZbtxNHXH~w}lwVgXטa~s)Sl`MEMbHby^y$& ʊ-6[?{lM>=w/tE@7U-U eEe'.h9Mч"U6mYCG<x^h4mg|W֦DLzNUKW K׎]1mgΈIͲ\3GNQn䌑-cQԵg͉^c_~ &M۲0i2U/,(ԸqEIǓNnYZ{Gg3ĘČ aa]C]8k*ƻZ7\nU-)˫WjkkI;C #I,J**_1@_QumF4Wt| ]r6'.'pn55ĭJqà3-456XhcDBb2n݈+ۃ䎛=zNY:eؔaH/>`̀ ' =Q l: i1mTTVFG]3(m^ؙ0s 6WsPO/L4iGMxKokv]zva]5|v>9K?wvBrn﹤'IH)եl c.ݣmqQ!zFzB<"Msѕ={QZNu&]O)YXs!V+ g $[1*pHJ|f͍7.j{+րm'J Ɩ[,,:D&n[S]6d^?~]@wICp)$.IXXX^M ~TI&!&&&)6l0fď˫KMě[6b42bOE%DIB$U}UQY׊e}Rh̘LbIIfseXg]Y!!!>I~sMA>AD=$$F+{}~u{afIJ:⭋wG&ЖCKܖ6Dĝ#rE1f֘ʊʧOk%[٩T [_9m!%#4/DhXPud{{7Stj&.u uY?}("y`·{kkH,a~>h EUE母}9WlxlFRG _4)F4|ƹ8w:woe-DP,,,XiӉ'FGY[~Noo N;5/O+ve!+&ܫMכd n]&.i2 (7r-Gi7/s;j*^(hmGO^8ipBcClކ " v5ҶJjh4O.N2/}EFA=#G OˈEnTߖ$IZNSNh-ib47QVޤ%$,IGVAR]VPfgsDDDHeVPQ,\BCGn> ,Úd$gHHK(o"Q1Q֛7Zm39eu+Us＃h71. hw6LLL 1<e h=&v)IrrZ(uPVr!*ۛr+'F'=xMaYߐJlL^_=k_FEEE5 0AosG s=ׯyG-K R -tǿֶ[j=&4}9Aw@ gS^Iipj_*=urlpō6kK81vz3mFŝ3XZ[iQ|"dFPbLb!q^ga>D^##/CtM̽h59-=#!u- ÃYSN&\RMrAw2|DJ9xklh}!E]q^3x\WYM~"b"3DJ<_ 㫫Q >.+g]WS16R`;T_]hdT5mTD2*>TVzImzj=I7SE-:qPPYXB,>M,,ԚL20Ԉ?OlXH)dd:|¿^=~udUޫwGtݰa**Hjk/n1b¼ HJ J'N3k `Us]Nj iՇE$$L>6}2afh-._6mhQsϴ̳Xr hpަy%%v_u;Jjo谦Tܱd2GD,zjnZ1dҐ.yy=s;8n Ybk%(s?"qY=e+.+~tCMCjON>yunkٶmwo8{lVV;2qU$'RF1ą_H'O>PK5h BQ*.#mt7bǙ7]o'5^V()mLppqi_zRi%醚7rVWijt(Z^?i'c%'g>$AC'tEiE2*2R RRR=6B:I]K$JRNj|.b S M7ϖ Opu |Wf:p瀤$`S6iݡEDs-PD[ ) gs55f@Dyr:KIy>{)" ɑdH2wwfܞsK\R/ B냐 Q n”,K?/he2>|yt(u٥L&S!Sp`FLFΈyw^lGcVxyYYr F_!>#@x|q {" vyE;;wD_ǵs :Aa]Ʒf,{燝J:JB$vvߜfHEQu{ςM:8US#,rą%đ %;· z]{?|j'kSښ> TkWJMMMJI:,/* r~TNJ,)jv9A_OE{-ӧ~~~H%)/?@",,̪" }YEUZNzLN8$?+%싳jUK<j-IO9vlTkǬ~knj-QKfCm_/["dML8k,4Q:r4jxYѨV wͪiifqշoxS`#!!!U}U?jJJ J4h/%D'vϾ[nH=xQh=>ĥj%ysfcD:wXi,YUTE[6/QemA[Q\a6 %ZhlxBZZ@rY.V6kl7},r6a & ֋y! u NoBrXΛbH$9戢2qY/;^dvEdh4-255F@2E\R+&:f!Gz+>` !GC22H;H-!%4Zdnݦdg48!#9cϺ=i 2eؔaSNE ?62@6uϩUT| G2Y.쿠g> loOXgaoCMwbqw憐4Z /c^j93^i ʐ,Jzb+^PU\v?T@!'aOTDLKHR0]ig! M)lhh޽;BYalGXFTm۸9&-4Z/M%FfFH켪>WyLLlt~8"UYY RX=̆ŬL&SGxvz]2 W_;g,]"`0[fn.$y#NHhsve 'C#GuWRE쒖vL /.9E564~6l [[^h!GBMĠS[qqqGI}sGZVipQףi iޗ%%[ZǬg1'dflt.55N6NuE#*>V0CbuԺDOA&U#%>HLWι;ՔjxDԩ;O;tlipSS;Om:ɠh脳nػA[_i]]M_ \ZIuvF#/'J)HIJ?:{vIk`+!*`DV{Ϗ(g` c\qsY-BTZP2e1H-*+*lae<9s'uKG.[oEqf>l<┞]a!OžNib|2TTUD=k,D [t/Ge -G nb0γCăd N9y!=]][iKl>s70fQS>3 >edNibb|bc9g6̬K.x߃P(:t@4m~Y)Yg_@= YR2RH\>r<`Ĵ,?M]Mf͝{v^iOI("e8j kFfF wbyy*gz#]GM--4~Zc̸}! q_UPP@\jjj"6ᵇ]p9UipS\dIϓli^޻;7f4خstCz/u[4hK>ＴSLyqEiD""$$d><."wHAޗUddl;p@W2*2bHi_65K d*jғ$̇HLtGیF>]UPPo+$֑ϓ%ɪ~{2t=DjB?O!EB?oߧObbHv3/HHI ֋;-M@i]bLak֚ 0ARKlYˑ<(Z\Gy"y̛y-@@!Q}ǯRTUlŃC' ѧZiYi|yvYSSh6[YQz"trZ ךg~IHιB8/OQ3IL~p^y7-̇TB'ёϫ'RC9i4 ~ҝswwO[_ipSؙkǮ^йhs=v"`NVFl̫ȃ#JJi$<jы{~&}d̳G"U*$ }G􍋌f\K7On?1gƟr"*&:e!Ojy~!\5}q^WI8w^H`{+H(do;S"` ~NnZ2Yf 2 ipS̝v;l3|pzMMM.]夷ۂ4؎Hs (v iC#/Fz{SCkbbFCfͲSˋy@PG"z>87.Zwuy!@낭rUUU Ц;Lw0ng &j%uӴMv[s`@'Iޗuڣ?o_Λ]w!^6JOٳ~Ȓܫ'o#!$D%T[DRJbƛu6kl-**##\/; dQ2&6߭壗Ƿeoiݍ׎_]Piϛ7xbiQiT^<|-Z0DUWK~inlh}8G>TT$A4 c3A ~֎iiL&SUME W"_y}{pl;3x`c tUfp8a55'v 3u1<_4^Dq[lURS4sE ];|[/oӀ4+ -S#! ~VsRr+,/b=ψ>|fgY;;#DFL:3BTQbjd '*~?R(M^7eDrn HԑJ JWOXoTkfC|whEDqe2ʠ3vE "Ć[o! KC?ŘL2)vU3HYtVƅj]  "YIˮKFG|dbheH"Dژ γ.VTUKJ^'0Ol47`CKCx;R"Jˏx"^VMV^S^TgV[]4{d{)Lt]*G=Tq70aѲR0G!ΝrBS/^{W;{&k(q}')*~k=ܚZI5 :nCu~uļg5C zw=Ҵ҄=[=,D/ڒ![C#Gv6WG4dZCoos#f5w6o~ <QϧUS)˪˪\]r EgՖ>šmޅ|= |x.}y?/B2?ORUti$99YaQ4D$^=~oՖ=-!}̂ o/HHA?b,Ern wwNݹ~k;Z$ZwO ꞩ;;L5NI\1:b!Cxcp蟡TTS;Dkk0g4bY+| 3QMҪU«zJ55"6+ `OlbmBKJAy UU[pboŞ{>M[ Ȳ]mq=VQyf]z z3%%lYßZKEsIJsXD76˵Wg=W+(ΞcZ-2m8".3|fڟֿq,:AK2d17bPsJ+Iɮ'jj-|σi}kC*j+p{y쥨{MeӰl立yoY+N SWasZ13ZBIY]DCiAL2vXH#];|>|tMt! 8X«7wCg휷a! >]WV<, UT'ɪ* è4ӅYS{%*~QfNҬYVRT]^*:E99'vŇ̇aGkfb؞zN;9-i>t&!-A$Uqcnj8NryeyYE}nP^ۭWQw7;_) Ǵu+v u/OO9][ljgҊCw@`-ds=_wM%$ܭ}RSs^H)JKFӱJ_V* e7.ed{?<*PW%,,e ҵ\՚k3dvY%a~uB jRkdtet鴞5@ȿ\=ak!2wa._pzywsHJJz bo~|XHN)*G4ꆣ y /sXwSV5 &vXȽfkˊpJ}= }QDYnnYϧ>/ .T`1# 4xZf#CʸJ9%/K25[=e;Xu_?$DHafո(HpJk*jD锈 }$;u3gE^_x]_ff`oi)x~m3f k9(;ZIю`8Etz|:Zۘ4'_5^{odꈠU->#(}y:uD7%Yu5u)p|Èi_}+)#Ů >F$X8 vpfLw|>(Ǩg|>Lp撰{QUA=|S 6k@ v篍9A$:˲{}g43ɩɡn-mnHH)9gVHT7WOg>ַ)*6E.m^\uz"T^KۈnB [|l}.Dj[kn \VRݭ&M)-C>M : [nLm }?Nn-q;ϥ_ҹwd7k޼Y&* GuYԅN_~>kk;v%)- itUVo9"8c#GiWSCQU4U"FY{dٞeFte:ݴ.J9qD  [*ede2}9%=d*S@4W$'L6Acetmy U>,w&D)m)s-+r$u'XS{,%((3n+uu$EZHJdFVF,&31SpRMHǃ&V~wˋ4Ё[^8ϫsV묾_Ys;  &7/&t-DrfBOZ bؑMY{3<V쐣!{]6T7Va%&x[{pq0f+(I㛎-:PRSMJD?߫}&g--^?ukso}0moU :Hq"zŸl<\0a{sk^}8, do RcRyE-11c!wCF*.qӢ"Pa:.U8WzkiU`9'@ Ko9.q26q1!/ο8u7x=dҘ]tE7ՉQysrɢ"Բ[)45586>b~*«jH)J$(:%]!.Wg7zC@$)Қk Bqv55-}q:еdMw¾ ( v33k'&:B_SP8 ]\.j_, +-՗u>nr;ɾf3 Fpimqq&NPPx6Zh8PRU`A5)5_\=O704:L#qj:j[mh5R@kՑUwɍ36VWN>K[7yç,iΒ|$Y"z'5U鮒#(e((EQR)v)q0a&k$`|FDrkk/#HF3DVA `jOH$!Q/WU ҡthscϖYgpVtc3Pg{'zmLhjg%e a2u5uj"RRQ CDA?1D[ya܂8t>;FaK{oto#ML8֑_m9RQ[9rr-VuvQ[\;ܬ'N?56+cSdf3Ӵ)i&]MQ*a_m[C 4q~=5@z.$sgەmsΉz;+CTUOllJr_2u+RVwfdXk'uƔ@ L_1!'%GwWx#ulo=erm,Ai~i}O3S2e9LWP;]vٽRk%jYii@Z[ԂH̭Ldϓ3tә{i.Zr$DKvHvܙV5,4]ͥ>!lvCP}Y}l ^>>lYN%ϻ2 Ax1J7sv_yuPD2Eǫ?ܪ=:S[p۫o.4էϲxgO}ҿ2/D3i@_Ikqg$U?f(V0e9V\JE :u2/g9uϼ/?x`Hp8SWW_x{_eEEc.J% :DX@ZZP먞<מsт4"dAY@MJ J 3Z@}ZYú!!&L vmf8d%&9̫K#q{a˪ZZwh %Nӗ x?ت̮'۬GTw5J #"gz|屎N)͍7k笃kE_3ۺJs[ׯpFqOa-#Hoe}.CDy8>-m}g"bTU00 >$Y *$:tHҤN1]7wsϵSX<r;x?X0ս{ѪՎE;ZYW]ǻ-7!%-""("=.e G [0"(;^'rafPK'$y}L2/fqa:ϖndۄ}-Qm'u?Xl3ēךWThZ{M ?w7.> Wq*s*-i_Q_n%Pv,Z|*-8MZy.0;wvWmɄks(,_X;BjQhF)%5_H[9vrFG:H/NΩ;wGX9Z۾SSkǞ#I Љ iӔ3k9aO06lR@J؛`2$?(_X%k:&?+ .zzzot["HZR(=3dJJеp\{2rHl;',.?6ĈiB]~8~|߻Ү=·ʼyL,kYt{Az|zX@ئ8JZZ!"w쨩R_Y\tMk/zVdirSBVoLin#˵YdJ*E_}4s)i%%I+I]3߃񨙪M;1ڊ)ORJxbv6#mP ^98txMa y!|_ @@bss3qUSw/Ggfbttt(J, !? F͔f6]9^,՗q0)NGwfGztvvsiEbT;筟:ɛflh˜?@|ttѨ'Qn@svXXFc|~>aǓ!T'W76X̳, -ɾm2D䳪˩˽#YL?WqH>m9lY˿DuMt 2 ɔHe Q%.&$BlχxF3cм<aK7oSס]UTN%?JFl%.\<.u)FGouHWas !h|q!L ͡5Т_DþqXY *2I(JTh]#o*a=w{2ކ{|9v-or܉=A-Q_Q%$]J44pK?BYRR IQqhYaq{I9IeC^қ>Mu1:Z՘qiFhFry~^`ڗd-K ؑ ޢ1H~={b;UTzrtse>_%y%# e/K#+#1ljk/0c"qv8O;׆v~KytS)?33m&r8Z&#'y,~\hZZ7ݤ5}APoG-K(Uw^ygvYAQϨzW@;F5$mQl|_ȩ r@$:'"?V{=O|GoGOb޸Btm d2lYLo_f($q#w`J!7!tIIOۨn~)ORX VfDfs.Tl6Ӭ$7R^*g*g;{ RcRw-5w\a.F(ݳkϥB|3zIJ\/.s_v<K\x?rTm켱 _Bw.we]͢KJJCKkT0Ec !a 4./az-$Kb62懵lU'VSR(?ֺIiJq}Upءe7[W~.=lAXѳ} /SiS]v]]V!yr%d4T4޸z>j(lNsH"N;(֎0>]~~y%z -8UswDjD3}VR[szD55JѝѪXLnO0 }XCs{ye.iB9QYRYQTL ZΦoiꓒܴhaڻ466X=yYˠ\[ZP[]b^3  :$=ZF(UO}VH.;ysl{ͥ}x[l^g>ɛ!nژ徸~=NqY9lN٫28AMΫF[Dij.jtS]SFXFFhFCMjpP3"n@l„†#{ZtWEΛ33{uUD c>R!AՕUdWTdU ~ͭ>rH= ,0u t2Lӡ_gI~a_}YWλ۫o;v"Y>Όy62/hX,@"9݉{y/,vMa}: "Q<F%=˙ﶿk,jl*k ˺}(2VJo׿ϭǑp=Uxl_ZʱF=-ї֖FVn;4""? d%2%~`0r2oGՙG5u .4no#ԸtfZQ&K!رpo=;i\1zEInǕT ~).DͯC+slWb68EE P-HrID9NIuIj5/ /z8ì+Yee#^X=0Nnw,iӌXail`y)ޭ?~+xTUqU(׫_6w#r%%9rJCKv:YUnaMI4%T$/`_X}#;BϯCiBttiiMʳ=&-'}vY~6^?r]M[wWaosYN_UUy;v}~oMUUM')עݐSx`O;8O_xPZ= DI_IQ[1uKRJ+꥕z $I*+\rG &/_{\hf==NBCBFΚ;iv Z " ^8GV2?r3  > ڛ$c+-C_ž ì?RRA^UZ51_kiUU775v3MO?LeIeeqYwVע92g7 wz檙hwy{ۂm{nY?8T)˞Pkf%ɧNjSl&t_{/ɘ'KKJ?/fa_gcI#o-jVI7'tyz(]~)2_6S9lYܦaZ^Nɳ=n>~+gv?c,^ mz6zy'L̼x@ /b!b?~1_9;wl߮r~QJŤ9fC:}uBJjLkf2Ҳ!?ZZ(5_?=Գly%~2O!Ԧ2JJ lDE-#Zfc43ĖWRLQUcwhmmNvkSd-_TU⍻}$Irbv_!wCx{P _쎏?vZM[ «aO*dtڬQ'5/تm6i }ֽ3anK<;/V&֖ԆhT[&-f(}` fX,ԘS׏c4i]9p։[o4p8eeJ6J)T93{:t^O ]uL&3B?G)Ʉ׳[^%s)Љg974pl#a( h."//_TTDtGt'!  T6it¬p! ~ٱpGVR7e`f~*-(ݥ+! > sߒKiR[y>U;TDx8\ŌmZ5MT>aOA.jNj# %%uNiD P0jĬbxsh!X} GŨ5S{ ɨn?Z, ]X  [JJJ @ x))}23Ͽ9/%w/s_sG 'c̕3! tHrϰ9lNeleub5tjjû$H?rr.] `+Ƭ@7#nGj}/^y˹-)`i˜-o4a'b1eNLgb1m 8LT(ѴFZ'>"&)[n=3m?{1n6rHؕrB60 Plijr!@]=t[/oUQ4:F|d&,0i$H_-ؖ/`G>޿b=|uxמ˼9zۂ-,_K}V!u@8<$2w&N|ie7owd_qUWp8ؕgŶmrdAV-[KJ$/=on=! ~BmWw14(E,2m4Hnu! xWWH$%t`ƓqD/D(RQ%22&, V[~]~~ 3z_d!HTQQ-@TԬqus!QUVd]mW0aaW{p~IHݳ{= > ݵx#f4hTI!g]H?09-?rp>!K1]  o׏\70`/V[g%;N~ 3j4_nAAD,vZ}=_i2?p?Y EFBƺ)F S@Wi~钡K,{Zz&$v䜑6̃4 [fns, 0i'}*T^k'>4 [aݞԇ[8N6Oeue؉6DhQVMִ8PcGﺹKNQL&s%y%VPQ@|鰥V[ixbe=wID_ /X bȪiHdYWȤRX Gę08vՉ454YеLwl|=|uu&.{$)RyGx>@P{!;WY% _XÖ쾽@$@ | vɐ%M͇BB RYZxbM}wQT0?lv֖Ld /=6m2i ǽ9BafXW\q.#'F#Bz"s~T6q2 B~^^D̂37>QsFAgo}WH/LqjkU@LY^X~,*/%CHJKB @Hrj,;Tl]tesʪت@ uzVZL0:g4k]w!rOdbg@_(200(..f0 Ph41^:&:+4:FM'VYǽ/l_S_&f⚴wi6X)m)sKySytH=y2~]D&A ,yi,E'e G{}|6N6;gmys1#+#ZTSY*˪ð1XVHNZWZJ]JECR] E@}6Ouۘ Lj!&Ia]·  Nn< 6kɳ <еTuZ-;%{݅A\Nfjƅ &HqoKiIo"ݠTP e/Kyey^tWE^%@cd˞ݜ8۠a=|/z#=MF7TPBVBDM^S^AGAtKQy 46PKkcI$5822'-YYFG577ϝ;ؘD/(&$KOOOIIyKlقbmmm|H @u6?9ijB`BDt` {Mga6Q^^V=һPWqv6oN mj~`~^@^b%+cmŮY`j%BIEύbG+][bTr; :tܴܿmvH_CzO_1}_ >:ĵ׶_8= |]!  EyyJDU{U**  &8"{jfզע[EtR%/kK!Oȳ=܂-IiNl[O04e7HM{_B4<0<4 4E4FWUvvqWcCKC5mXgmu-:IIJ|yNwǽO}a`/3iLE]E#'kjwְPS5T7֦$$;*;~o`o6:6:p8/֭۰aöo.AFFƥK._n <zzzj {AvvNw 1roWc&WVC##co2h CC]uE]8<`%>HDw vg9?+HZa~,LC&W<+}#R,QM[o ?\RWTXҨ``6t4hcԿqk5 CTLjjc?p?| 8QQ;|#brRsf;vts~m;l|t=Yj~4䖓OuกM$00_OF])m˹ä1PMol""A>T")'2Gɐ'lO?g$F%v 3\iSulEw#ʋYd⢭ms`l⏽PGϿn\|#8?];)Y)7.uNQO ,40p>|_q^ԟ{bӨ1_efHJXYj"5J#jjKj5,4f99NwTR7O/l3H$^vM; ƍԜ8qIp8\G>ׯ_r%99诿7o6(sFzU9UvN3zM%*1NMQ͛o^{U\Em4 ZV]v]ބsl&`L3m7m<#KI+VOϺEu[MÙ@Z4hQqNŘrrjյs]pa!p~)/*{d _nyΥ3f@|t]w;n! v:-qb}N*M0T2/gNcMrbE֦Li-1Wl?_,)lyb#\JEq}a"31Z5"v:*q/(.b@od?nDRG1p&?8Zj>3V܍B EvӽO.fK7KsFzsMSmg<̇-///^DGG iСCG)++=z uZKLL+CJN2W^ Etz }׸PME͉M'nmh9 x\xNCYfg` 'Wl =Ekڡ=qG;%>H2˸=3 *++'pŠŋZJIII`*8uꔏO}}?t @„³3ϖ$[}5E5ߋ:eb2LUElIZE&ؙ4ⰂxqHqԊ*kk$;|B]?A;_ᬟ>,0ċٞ c2+FHL 34@%QQGZ, K=GH?J R\cv-Y,h!45]6|YW9WlAOWs7<慀ӡՇ)'x[l ~#-؂q|B;> gw>GҧxLAOg-tq&$i(QN3p抛q='3sA~a댌 aCTTTL2eᎎ;wj-H$.\0++cժUNNNbb?p6 iMI&(r⬳־]Xmz"THo,m|4Qs'eL2m.Z跣]HvelF/=3=^Vt=yv޻{Z|~}7ެbȔ!P`Q;tGWC@@ﶿcw M4y~zHkKuv ~fʉSlrMNB8Wr^3ĤZ+<(=+ {.HHJ_8^:t3dC/`\%If;-75T)d) ?[-kהԕf9 <=79[mf$)o})qνcAOstc[Z~JWH_'Vøv  q!*ң]Kv!;s*/}qbq!ƠKo\zKHw..ks]}}]z|[oi?C\re6~f魽6l/AOГi-55w>uԜ9sMD `<\km[`= "(%vSڧ>ixϸ6&GM(Q45JJKc֓ 󂹠()1)>N>W< j37O9q煝_7ej*"#nnrr"Oqrq ->wHܳiHkHI=@$DNMqƙo2;:ͧMVcmӷ~Zwccnc7M&-[/nbcFh?Vs;u*3)=OsDž4m4`,Yw$ eB4dnŊ...꩘]xرc111ĻҮFD^a*%/ϋZ޸a0O>r50yU_O QףnWY[EkT(P1c80?VVV,YzAE,eD_9@--^l}ÚOa*%/:,7u']9 JrJ~O$*+"K/빽D<5T7^wx3;320.DeeŰ]cqU;VڙY߃a~W3RcVޞ^Г?ddd iMM6 0tR77nkDVfLZ-ټ&49 #lqWw\mݠ9Nc6 BSO]?d'!Z|,qtQ y #x.Ua-Wzzҩ8XEG} ͇A>FRu䷟Tt5?/ ޅs:-`1c@OsaJBk[qqqΝax%$$Ǐ` ^j?!k(xQuvu J-E796,N?t73#.^srrz{LMv7AO:s6VVkiRUomRV_jV+ȷ9t$Łq!*-7I3'1wtR[s{|m:c(mwmf˅ P]Kv{G`0啹Y)i+ ! UHUQI'0x}GF3MY2Vܼ @+?l*unqls?|=Qё3౏צq<}i8ِ.ʌ 6V.'5ܞs5 5O>+E-p_ˏߔOƨ݊9rIz~p^zAATZZ //_wٸqcGGGDDqTdޒhnYRVYI0`TUc\!56ccVPOMY'"$f#MMnn\<\0yH{~@'/I>n~).hNZ \Gmw톔&Г992*2"T>nD)F-ΌM\WG;QMl^ƅL5}5}s}e;=OM}sFUl&Iz~p>jjjD"Fݻ'$$4{Q˗LM͹^~]UU5?\KKK|}}ed(5,ڳMDD3xr]G=q5юIe!-vȕ(䶗+㹉O/^~f QQTj(HC6ښ6l?{wd[̝~۹5 SL4rDDFiHWu73I6ͅKN|Vj zҗ)9R2j8cƢkSػ07qGvb_ ƅݳx466ǥ}DBZf͝;UU2J24?XGm[A\x1 6q Ņ}.,$zҗ_){zziDS2V5axE}3mUWWٳDk!޿ҥl.>><9)/TRe dR\gP 1chꨦ?mEmZ(.ĹxyerM5d +'kmB-U%UwX>c`%(GeqDг >NVshGO[=BT&]+Uh@"KKhꨲ%*X0, F nX) +%&²´6\rГZa+(( CF$VWW+((nnn --W^}U׬Y3pDE)`+**nim' ˑD<4ձ[fa#~?,l6:Ew 3%F,/6,[ɈWdG+xU¬l8xߞ?hV~daeАв"蜼O<%3dzzzxq[YeWUqDU@.3 5*TW~e~QCQ~%GiǓ[7>ϥU@DL>A>,@%|ru^j[{<}]0$@ mХ±bR889E8!?6C3+ I7u$` '9:bӌSBO=m|B|+|V0q;qZ5Ho BTׅF>|NzPՠg7[@ Jgaa5MxP^PnV^M~'UFYFPCF "7/w{s;{|epcmZkZ?>Rբli9rxО$CLYLPNLID zҗ_p" bg8x)}'\[{Sg[[4460R44L\e@WEbג] sDk̠HS6rc-?Cp--ûm޶xꈛt輅 &P1ç3¢.>wy,y`2ll=>JΫ+j*nuzdRYѥG~kEΙ;hhqԥ^K_{>2{IL$'z> 22=5Ԕ, +beC +Acspu:4T7l_}̉+}Vqek'9{F@X! CZ.@Y ~.~O\G/^wu[AduXcGnin*"z"nNޒ<ۆ *AbFbIw0 #=Goo6͌mml}-χw+6k ?{%y`2Bc(zl'[On0И8)B{/E44׮kʧaOyʺzB/Q MuMil޵k";#g 7qQҔ NjX*Yr8@ܩ ZWГOX]]mƗ H͛ ܺu7~nnneee{͑2qqq r𣖖Vtt4DUfccSVVg_882tu(w1F adcbfSc <"#50]s@~cfffEgx:_Y))"tڊT(R|ח{G\N }d <#$50pYщ^5kk_:4;iƯ#EjO)IچGz_C@!**ܬECbBEAeI]λ%4sBF]9ve[6v>vninQ(Y'Č"'mC ,)v҅I H|TГ,*N, C;!w>:z(={׃ƅbwWweq%EߌIFYQT >b0JZJLF  ߣ֓[ŤH,Faf {| :]1*c(t7z#~;}O{];0JJ ?\prGF/=;[Sk„ O>%]]];vԩ۷X[[sKiiϟGFFNklrffCl VcLm`Xϥ\-MJ1jjddAO&G'vq`ʼ)\<\|774sy<z{uu# Q-#-Nnwq(UDTRt{n2$cg/簀G ^^V"q`O;7;:)`TF@R`qnQne()|9)eͫ@/=`hdVę3geeek6mbggpѣGׯ`ݻwm͛Ge&LPSSBյ^pIߓwމ.cCJ8;oohL^]՗~ ͨ{jfac7xZAwVtqkAilojm-*2MP^΂?&PbKi%鐘"uE.l7{yv.c Z /xJ׀tؚsZUW{^w=y=|lA5=N"YK3uKgO޹#% ?"".70.DM0l=sħ]E++맂O?:! gpt*G/R7Qoi0/aecU6W~M3GCMћ$3R)g(zҗ_bؔh$`kҤI0'O$e'XJII9;;wttܼys…ܾm68!Hf]ZXXXYY˗/{{{Ϛ5KEE733͇gwYjX'[q[6)"Si[3q\/?!7N݈>\C-'|%"kRR3$=)R88,xVۖq/cň?/ !eE P/\UE=W. /!trix3/c#3/cTNP);ttUgONjQkvm ޮRpt0ga`*NZۋｘp#iejյHR-#-\pgm~駧'Ϛ eZx;OX!ȗ{6jQXT8E_O_Bv>viOak}u1--c'zҝ?ij &C̓޿p_^]O/F^rr #igwI\ ;M`\\1 i11z]wZq̝D"F ckAG]sӝN'_2ańY--dst=|C뱭ظ3q6Dlvgְxp.dp@ГkH33-[nܸQQ1kkkB`c;eK@;+//9`nݺ넄Z38%;h=ڀY B@@ TTTddd lmm/^i&??GDDŽl|Oy^zaÄ )U%Um>Kk/^FDSyӀGXPW -vZZOL9QWPQh#\NXNv68޿zci~(/ZFWċk-߯&98>:ϳM UvRIJlk) /yZu@^$_FmEmU1U )9U}<sff 3 Eo^WUWȚƌ6<0n 22m՛1_cuAϟ kEv""b̘1۷oYjիWǍ~xٳg{{{_xmym^^:p@\\ׯ;::|}}w9ǏGFFdcVVV1h)ol܂tikIuaǠ+Zy#&8-090R ~eǩn|1ؑ;bzp }}WMjl~  -et<}<7+2KP.Pn.-T? 6}jBۣjI#NB#joZ ~%mWuWV@}܊8!-~bogoWU--3|_W\´ 7'u?0dÛ7L48q! 9l6HI= AH'Eڶ4iWri,,/(ˀ WxcGM:?logLPҐӇ÷ ۈĉ&4ivVvfgFZE2cܴwۄ::^.~8OS^Aat{c=ƂtyK8}~yOwό3hڱvF`m3=%${ ؾ3kd~Onn MȪo>E-~b?PT$&- Ѣ˒ZtT׵ J JH6Eo:p"5VjՕ| &3r%OCQKGW;p\Ҡ'=%Mxzz&---_xbo}OOXPP{;v eSUSC?S?7\>t@ff~!@/㺾 As&)Dɖw܏ ۟_PJB#rA}rɭsSHB%ջ˧7t v;yF|@$Y0,++2_O^&fi&iq&aaagb0t4HGJijkza6v6,۹訜||!aO}WNu^hd$+9kͲ*"Ot>f1e2dWi;>|\GR#+cG1ܐÍ&--'LǺ~I^=G' { +%$H5s3 y,,*gȎ..w0.DqDžz RԖ233#k<" XB;R RݘD=ߣ)dW'kMMz kÊamohg`}z>{/w(?9 yQ*xFm...ZZZT {(Z Ahٳgm۶ sprHJ ?r[NUhWeqevr6zԆpqsWh/?<` ϸq▗[X(]J[jf'eTF?%m0L|0DkQG>N>gO>v`tɭ:sޱc\ \:|)dgȲmsxH@Os[hhh0F'N̙3SRR <?W^3""h~֎/cBKrJtcDC9Du(xԨ˝1,4JNx|w5#::ccgS.gr=lN4g'msM>t=#Gl; !#!=wVVV`xl"l6z<^_U=qDʅ0D9DxGhZk2-U-Х\Ie%&&&$$ommM#a0;wLXEEEqSXܹs߽{ IIIz ZT٦ċCj> hrF/㺾4ԊK+..%@W\͎lmRo^cFcC3{ s N1N˖k]#pⓝ[Ao:l۲G7"n% 0ӍޱpGjL걻ǬX dmu +}V #!-ly2va, 1 k#ˑ #z2χ6-%Jci_W ;ҏn8f['[0BTu 2 :l zoOׂf&$&>:^ fWQy,:IU;}kM |b|+.Y$;#/@]]lp\\ĉ={6vX&yyyy/^044E2NnNIye(B ?$~7~+b8qx,LLulG s K KunNEj 鴧ӟLDOtVu>~[o4^ھ w7osGWx5`xz}Tߴu3g& ߻;W}APrTZƭ^` ?뢰"RR'_Dߌ2ʮ '7Ui_ا;Aw|4VU%U-,]F QWo_cG@IzڍuxxBeV^]yaN?qWFT>\\'9- Z B|L۷oћxmmHE0۠K?30ohEYE+{p=C?ad Fh_k`-7#a.aK>/]N_jtMɺu::4^Z S_,~ t`})߸ы`B߄ndu6.sArqfיЃ_cA:gnfdM WAEmse:7Q^\RȇvPK 7 >&F^GmZ??%78UD\jGv f5e572n06 `\‚ It1.`>s6뷟䲒P_@PT0y58Я2+8esjo2ʒssz>=Iϑfz J)((}K] 񱲲~_c~ W/ďGBq]/cZ?.\9= +L\_~|a_𣘯4U=71ckoW+bowmrrtQf6S'Ih|h`'㙏ɛed\Gco?mߕ}p|`g7yf B.U|rɞ=VAH'aܮ%Ǝ{Qa\|,,􂸚zvT6 Q Hs{E73w6ٙ]a 5aecu wyѵ5*UE7Aqg7kid0=ѽ{ϟEa0sی ݻw2A%|5⿳v5C?F m`T22 LQvK>_\t&ÔMSFS޾'DR*l(s1qi1iN.|QWNik(eK 4޴:+:W0w3hffbfgnWI,WQVJk8|'5&B۝L?~7 t,w74ߵ|nYpC71C7oB4*`21zCBv\ʵs 595rlĞqgDžbt=}uu}Ž[c^5$ wwޅ򮸼By?\|e¸;;㧴s03 [::4qܹ[n7oh3_Ujjj xVaD%E26hknkml 2 `p ?.@\_v Ca~5Ĕż~v[oO8fQsrzmԴ t)9*ǯ4j #_QPB7!dxyf'c<.E݄[k{xMF:: BbBh@^˦싳:: {|tsŞA2v",p[3v @xRQp)9)M8I~e~!w(;V 3 sHJivL{6mɠ'%OI A_{Y]VddllŐii{h-`}EiLLF _Z`4Ж-BTcT=s=վk&z:u$_#=&4)TX!O O8qWW_o|Q]Rv7dl(!i!$ocГQQnn۷oϟ?ϱ9sڵА YUUpYII/]hl'v(ߡ]kڻgŰ~97Cf`Cd::|Kx~l<ԻҒ ~zewl;(^ңMOgd&׋~ʦﭯ륋$Z>iү!,hn8}ckSkPT*B*ܻq CO7ApK6ݸk) ˸М\p(s)s99yKrul-Xm֛m~}iw?DeedCFPVV^jΝ;ǏٳÇ7n;w.$&&>}cƌپ}+;;7E `_O2g * &%`k'::6Y' urrE)(:<" Y'VCSWg;gbՖ0$C/l:&T2(Ri\\ς%$@PU1uĤ@)Xyf hmj6w[AF'Θi)Y\p1Oo`j||#0[@R৷s3EEEE^JGE\\\``GP,Xh"33_?~ӦMllI[Ȯ7뫬]{{89 wh/Y cp@Vdcϋ%%Qٔ,1jJFivvd?lݝ>ɪ-W%J5?^P[xn@ -rd Nֳv-{lxeemN dM'qhju]KvArQ[yf"xIYFrOWT\* EqJuɒC^SEdE̺:!m!䶩:%}t|(Z<i2R伕H-Г䀭[+멙^ ].TT=Txy?orh&!A!zjk#wwTS]!D#R!`㇏WqV0"nnY]#q`<ﺰ }={ V9W_]w0 fhfk>< [7W_@ eۆK7{;z%'K͐!/J;mOåDE}6fIJVNZ 'fħaO@k`݉O. Xǥo9UDU[cHL$O&^uUuqs&0GAv, RWM=$'I2lXj0Ocdý{i O'L`VÛvgLf&ef'g# խ-cwgEܷinkrkN۝6(o$L 28h!ݦa[>!klNb|^FOFg4mii}{-ʼn wbbblmmEDDhjjByMZZڇx<''1c+???"Ovuu5?555EEE赭YCC)S3 jl%9/Bр>"znXYjYOg3FuZd%$sqa81v ݋gkoXڛ+P@$GlPG?AAx!EG*i9`k֞ڄ~v!vA A!M!UnIn. .n n$5+'+ZPC$txlWbK[[[Z5 _'KXHRKhV__YeIeXz̆FO{va+@8JeTǩ {v{LL!M;x={l 3S>E|CefI8357ձa N  rؐ䳡s '3蹱! -.~m:+:ֶܶ~B? @q[1cQH!Lр{Ĺ89[Ql%>M34)g<~𾤼$mu2]-]YfMf#w) *-}ǃGut6b ]Hhj\3EDžO]u1"?OrtYIYH>!> EME9U9QIQ pprsI݃wv455756VVTWXӈ"$;AWB\BVj]VҸqSç jOlMlNu6vn}GcǢ"dp28h6I7dpXdjimk,mD֦6 ETIY ceiSNLRA0߽~c# 铢brr)#9x<>333//mll$#_hhhPzH.Z흭[ⷆB ma ʹUhGQ(:[_B#VT]]@а-ؑtxy%:ҺuW?p5UZ 4?]|Ɩܖvl}1\\||^Ut(875 Oр-[9w7jh) CK't=B*&*^דּ3P+&feJF^FaTTp|ᗗ7OYKYi$YEYgr.[9-UN&Nm+1lZ^T~mǷqr )5lmbaaQVnj+ϮCTW/_$d%_uPyg?3+wXfP$46x[^a5aZc٩'wa=JHHdeeAPSS?㿆چF ^vkSލPRRju^^N:&8sTTJeeR{G`eJMMMee/&Q$''֜'55 AC ].=VVJSOQPL25_9855<B8p,\1,KÈbޞ+@gȜU"n7>xy 3hHؼa`d6ڻ bagYq9sPz#߭~GHYcRꂫ44 7aG a+88$`P``EKwnb .l==lm CZ[?Y."(PҜK|MW~,x_v-zjyRm $papÛ5@vE3)$hB*jrqݍ+6Q r7^o""TW< 44_OMA`SvB?sY#wUz#ET`Թ=l_aHŹgʖv޽YSS3w筜SGjtꑥG ]}3 ii}G9ArRRlȖE/BZB\C^zk^$%%]\\@2, "h5x<vg'&`Ov;oabe"VZ')\&̝p* }*&O/ ͌@JCK߭z'Q|ƟW\8CgϞ>gHw|qՕ,]vh!IkALaa[JJʄ m) %G$oÏ>."gȊ !3!CnM==utJ*rϹז^<#;LKIL{{-5\:{lPza NI0{=n>n*0V+K*32gZW`^l7֮1llPFcƏ9v溛^rӚzh[fQPQiz.-M- C_/ټ! ˈ #O )).jB h—,,-kul$'ws/\n}耂|0Wsq=yZ{R"RRlyXw.?7?(3zzW=me;mX[[۪U<<6bZkBVzjҪ>UW էO ?̜dZ5>a>g\j+Z%~K'}Nrt#O۽:l~zsx1j\ki0%d/?#UV-ټKM'4F>mm&MPt¢@2so͝kBfx77!996ld> ޅǏH%%%;;Zz4truUS~=M(Lg¼ "Oٯ0¾GCЄ ?P]<ݿZZϟa \;⡋>>{M1w_Wߋ/J)H98@>fwsẅgnaacMHBggN\4mB`0imi {8ӋO22vU9 i.k~ Ba \ H]?y]9Ms*+PܸZ%5!9sSL1;#In:ؕcG<urD2ע ͥgH2Jz7^ߘ>:Bfrbd֌ALSu*C,AH?T\Q.~A:FH:xbb"@~"(&k8|‹ݭ]9)9uUu-,,ݳsa ~*Ȉ>zO nwYhvƲA4l!h)5 '7*K+O>u)! ͭ,_v|ہ~MHK7bTVPvvuTjFFkcO/?>/MNEnǧCOA?z߭#,Ii4qx-S$v"6eác3Ddmwčnwd4nܽxw݆V?6c, 3Hy>(PfBhiIӣ0ݰTI{')(C'}kiv+mx)Bp^T1+/wGG}jҽa>>>0 MhhiAKϳڊڟ|]h]VP=lom91+-T{ 9F3RP7bYN d=4iH制6 ac#"._pҥKd}M}&;wO\%6mf/ vq)/mD@RwEn>nPH U|}pBAAU5f qhwبu~I{S^jg'9Ꮭ~3\]ֹ|u׍nÓgUVICmÇz|IKG;gGV*KU4wd>|[k3?~"noXٸ^5 6Y<2F%㋱1>wllja K())99˚څ|왦&iٹٹx^#qvS'o5Lȴzlv*o /_Sxrk/^\wAAUVVBBb+O~dNQnvI[RQQ&$bEx"d88'-qiԔN9r;5(*s+X1g&D}cyIIr66ێo%;Dx{=v~bحuuz+>G AA߆SRR,Q1g6w\1!FFF.\8x𠍍 \!? /&N}N^}: iu4u`A1k~z)73//oҤI -Bz k" N·D݋-gs"5(lo9}Q.xCyCyV9-M-͡a.ZZ?{ĶC Z[Z/Ywa4p^ֹ,(&x/򞤬$B*>d5Nw Aldg`> vf_𺠼D 0m~-(  355 k_o5>@ ~Vh>}CA[7lodœ#K@ۑD]uDGPPR\8𖡪* u-[;wAIIjvעĢV]5jOc}ioU G6 A#KHJ^}~f^}׆- hn*R 7Erd GDRNf8budQ4e4f\YZ#R,֪ ''%H>UW }M@=:-ҭKO\??zTW2Fh̼P5]u:XZ ɲ[n'(#x!Fv*5mLu0rHLvpt>FѬu]kݑ[>']~_fM~h##CTT2m4o<ȵk %%%l ]yk+,'lc( % B엘u|f{{yPr@ A|Y>d}wWvvvNN\b=hB|ImEK]<԰ %k'%G$9یhhfef>k}mgs?Cɹ>b՘G-Ml߸:I9IXOA1Aϼ#{ARѬ?A6/4yp밦&q7;o<Ґ-6ܒ^,k7--ZFD:r&s o̗C:`͂ӎG>}gg,am;%_J}?<)Vy9̬ @NWWWUUÃ<({._|b15|]}YMRt+ ]K,1eVC&h/kډ^]35+0q]\DGOA`v|ۤiNo=w\=`Pݳ7oCp#z22dBm+Vht?yfpn(qԍ{m81ucӉU]v={h$c\չWo.&bc(( 1 d[^8PNLo8!P72l䇎O-=*0j*-NHƞǷoada HAqg w(8pR}(A\E՛f&af,'%xn5k kt&ciӫAOonsfVfβdA>cob{HEZxsғK5 imi*-h^b*lxBv,W->JK 7.Zh<ҏ>.<^`xlO\?1VբhܧwώΩp#>$>78'0Ggy-O͛7ϛ7!ڞ55k.Q= >A!92̦3MM^]SWv# EEECBB@8`BMMz~Yc]#O֮aKcsq`bb?+ƩgwіQ\Ysrd ZW]BWRV4^rIZ:ZPI& Zͧ˵NcT?9 tt~ 4ZӪ\<w$>r C>DOxfO9~ISu7C>ثFZێ>mxːk +1>Kz."=.]_S𢡶!uhP :Qל/$?nll|%uuunnH|K&J?>EhB~xyn+*32BEqRl_\8! }1lyyyp-=U`lkm\\ݭ]+=6ۮ `*0bdFԋ襣*gwMJ|`9Vb(|Y'gfqVGGǩpKO.BK:;;ݯ8uCy++hO#⣋ V/A@r0t@k iЄT>{`wڎWVЭs&Ihmn ƬP@e \qzGQb}ħ"D@|yav[9+=r|Kۗ^?7_:YS,[rp@g|cC w]>WD1?HLLܺukvv={@Ё5e`і_) yy&L22^>0 a 'V@Ӵ;w& ׆-6zzz3GKOxGG]U\?Z 'Xv?YXt{ɵ'7O|=]\E<;${ɫWB?9s KUYvȀl; ΋:Z:;+*8}p#84YYKMuf)-(C2aNn}.#' ao߆}õ$d%歜TE^E\oyj{({ $މHAqo]#%?_>ry^%*+koxzora 0imi )*ddE)Z;aQ]bƌǏCTT-3\F3AhWܝLK'5 yh9s`Ű& 0 ?T`f.Nƶ[Zt4-\vqAa^ln6޿KB2~ f]0}ŤP.o {f!ee@~fesIgFp&'KMMHBc}-[HI&GKL@ߩ,45Fsޙ gyf梙î| ;{;E;!B{ka7[na#$y;]k]rVɈ8:=ƃ ׎3mmZ+-+F3͌^oX -|%K_hhwIIQS^,,KC30ޑJ J]vegg[ZZ%B1/c5ϼ87$? 4g%f5ٻ֡ySuf}ݻ.8UErRYr[[Zk+j?YRS +0scF_]ćP `hg}[}E5ES-İD_ 8UxI!B,X|gp(}-O P̙3>>>X<7uwp gPhnlv2q-(OqF[[NA^xxx @;  "h5x<YAaz|-,,<?~J s4l]iG\7QvnD)J JO>6̿!?3(9zV}:O>'4-/ճ[{`-ܭ7rRr.[!nЄ$Ť]4)Q)'/޸M?ef@>hu۶m w5oN^NW%M,Ck]V;=p e7MoZm5BBBu̦FKϳچ^瑩 F| ݟtad` s|l|YrȫcᎴtBXP6k裱ƻ](!"):9z\P\x57o~sڪZ3Oo=%>Q~"h -M-1A1hIH·JE[ϟfJg4Kd)-z+tqY="q]OC5̕}вkꏕkk=gai1_sU]yveފyаQh),.Piv4#$LxxѣG###{NNNdMGO}N{uhdqԷXp?PD0`5 Ȁҗ\XX2l":A4tOЅ^Ķr?56_OEM޽o]<4pO@wvE3haSqjْ/%w#22C/~Ew r?kˬ Hxvs}:=Ixz󩽡==]ӥ[&@454%&DFGEFqxa ay TPU{^t2q(6Anh+p8}M} C6@0ny;^6|=3a>8 z#;|JILZq gPIPL$INNjtt#toa`!dB gez+4h]&EBC+9;xx8 3eIw}Y Hnp˳Kg;}p:G"5:՘Z+\C,ediC[8'MOڝ>:hijѷyxцEv\IAӳϮNKO{¢@>P_jww4! ٶmCBg/mqBlhtg'e'&`ёS'N7M봖ly~P %_Jnͬų\ƕcWP0| U%gwozSOǦ3#QH:E]B] 9Zq!qiixWWNE!UǃD )**u77`Pp>Dy_ 8v؊+AA{Zjф/GZLqշ:4k!!bF9\_xrhUU=TD|=5 5㟬]_+0?%kt]u7kkC L ' VF|65׬^ >řl7iko1Dv×t mȔ G63w;wA /<{i@"" |^~Ե]s= H~~-[0 4(Q)++;t ) );):A `dC ^Ī1µoa`b VZn ++h Фܞs}I=xg06q@n]ny #dkR2J2h<}57#2/'7PPo۲HQ^}qVaOl''~ukm3[KIM?hQcW?~̄LӝIۢϓ6(JJMKMGaVb G@7An6J+JCe)di)ঈAܹ윕z1uuupIII^^^yyySeY9XTU٧ `ܩnr#.${г aq]l^q'<7muJln&m&ao®>@?9YŃed鎫,cq#iEix/bИٽg%f3 f6 $hh4W@ _~cVV-[ٳgʔ)@~yzzƍ7m$!+J ,K,zd)4xw/̔ҟCDh]RR0`acAx^Nra.+#>{UP"Z?##T`hҘh}#VGuj>a>~8̰US@?;ϭYKoh-48TgNYIy\P}&3=93߅SPTMz/X.T}vtФ444qsƆFZ::cxǀ,#ԤT% ׎0icO&rC^?(+>s5kB5~RW[gr햛]sP?_?#mmO=BJ׬EFݲ֒kP qwqz)/]ںk+EhAFbSc%)WY--+-;UvQ>Z9#"">}Ǵ4&& ijj20eRޞ焄</%%쬢B<%($P<}aBCPL@n((BYdx$ :7f̜ /%(UuO Ʒg 2}# NFoWq:t E'Wף' oj&Gѽ/>ձ٢Wo$ȠɓnZl=d3.\xĉ-,,V\ }yQ'O{̙{ݴi==T.旛Kh묓"+++(FQE]]Νp*F/ '''#Ql&rrrJJJGEjci˗.###FCC3uT/.\֌cZ]]- dɒ+W"AF [&Lضm!(8a s][[Z+ 2sCZ~KCm [gvD7&,:0:-& SPb"C6Seu zޑm}Sckk~z8&7o_?}ի!B())qvvvtt,//G8qbڴi K {!Ç988@JOO|ZEEE/fff TTTeeeV={6?999ǎca[<<>>;w}y0W"CCûwΝ;ƍ222pd۷o?y򄊊j˖-GvCEEvEЇDÖDWWWziӦa'Csנ6O,҇Bd71bTdddFsNĎ4 Bee%+jcǎ%fLZh /---++n"RQQ]CG͝QQQQ~~~0 UWW# Qo ѺR@S .І7@=GDakbb3PРj@C ,c_^h#;;o̘1MsIIIɍ h:s̋/P :`;-X] ؁3rd^ %Sa61D3mn1I)A]DIaOOwN;b [8֭[h^aы6#OOϸ8!! 6ر2EaӧO~7nܺuԩSAA)..Fz!h҂2Xgddǣ!2JԽO4iƌJJJrrrpI$9<<<44ӧOhVUU]`… %$$HqMMMhob;999>}ܹs͛7{lIQ+JMM%pppNbڴi'Oj3X`Eh(nD(vXRRY$C4&be ԘѰR#?u,D6}h,nD۫n`/EVcƌFwf_E鏠`'|0;v,ڀ@$3u[6 }$Ѱekk{bPpckYp٘1o]CfVu @xr󉣑#o_s{hZ[[sss2M.㎔Q-L2eT hkj9YW`dag^~WkZa $:(F&-&M}6:c~vY??쐧:pJs&IgGG ;ns_ ] ?;V{{;w,-- 6mtԩI&q[v0o޼e˖7OPC@@qq1ڿ]('553!屖WPz@~Oe+oʘ1cԞ;0bhii2ew=Ēqrr˺MmU~RVV5Q"&&&%%ĪG튊o݊}((IHH`Cњoۚ!:xנ0ZWUU}׼E1'vD=y$Zc~, c/C*a # 0PS1) C,,,ك~a PЀd{Gu-ݕEZ^-Yrl .`!  Ox)$/$QJ%1%`q7YmIkUۥ9j%Y|r{gv5qdu(I;8o9*I+T/CQ^)1cA'A$!T`1s&666==UƇ+CCBxRR:dbcHزZOlǎ^,իWPյo>?:Nן~gy&te`hiiO 11@pUn-ك(>Gy䭷*((۾cŲm۶-[l޼" X5B"vر]*v=))iɒ%˗/_rŋI 555{8x ϟ! Otww[֖x4ܛǜ|6 v{*4 \1$!3E\XG+4;rY|)86pR(E‘ňGtp48xpC c)ﹶ;AA! N1KHn=+66>//Yrq;0NJZpp㍏"Ƈ(!ڈxx($V!xI׃-ćnb@SVUcIVTT p&L.UJ~ -p6c!$J"b"+Hw&2>U^'+*qXeA2UK&(Q [R|P',$lAADW{eZTT 4 (rѹ$jWb &F5 Oϓo=V~y9#?Gw=vesLe11w~>${:mwW33Gt:/_l٭޺~ )_l۶mPq$$"?pD$$I$+vb"?N~~ԉ# [AAD\r [\v>&6e`TT # ĽOlƲu W߾k<6g霡}iS{5kZ[&KSRjy|^7Fh0SR3r32r223'MT2hJl Cw>?=bt'g^rP&lݻz~W\q-vis<a߾}'K,Yt)~:%{ 傱gϞ/D8pB"D?~|Ȏ;=' pgqXRmdȓXy^8vH*$P AhDٚece|N:>m+Be@'.85>R2++%cIO.X@8b84!e?QwZq Kvj)))$ϥ 0<V_yI J'%%)H@#(@UZA0Na(!HQT2d1'H:E+D nثW$z"Enx#_1n< pXU{,oj0TSI Q [f7yR',$lAA ~Eb"owAmMILI].$ &G`Rئ76:}{[Cp}k@PX ެjW[+*UX-0bbc'gfg礧e!9ikjkkOsu1sΙLX4\auao 9J-/ݽ{ԩSo|;iiij|_|Ş={i-Yxqii)qE+**TUUuuu/`ꨨ9y$LR;{O?}ȴiF; |UU=K^Da eJJ b"bZV E K0u-Ԥx@Ċb/ E ֈE.fsI*t-)3QRG|><ܩ#܄Ô^lٲŋONYH" ,:\r+ dL0Q8$$RO-m)_Z~/o_@(Nިg/=ݺ]fs[c[|bgY:gӋ |^_N}b[noΤ7?gu1o{nHJl #+lM6=s?oᆕ+WNQrW_uc4,XpE͚5RZq:aWQǏݻMMMZ#uc lOMpH(!&0G`ar$60``쾠-vs,xF.v_LLgIcc"سnmTI@< )ai>5ɛOHH@YMTrGu;AETPb*']a?*`XH +FB_HI^+hQM ј=!ňMn]AA +lo /*b0=0rJBrPpDLܘkNqF[e3x#ɝ*)ɋY5 JUX<Д'@ֺurssyđ-  TȽWt&ňMHILQQӓIb rg<]W ΖItNق_{6yϫz^gƔ9S|{nyo ,<s(H)a= /P[[`k[ָχRSSSQQU]]]sΝÌ3>u"ﯬY?k֬9-* } s޽8>v;*L!p|K5x|>j聯K Ui}`@,=1q0ePtcE s'\$##2JBGDU3!qU/GPLJxE;&f8ǝRNpII IVL (oHIrMp4%ֲK8zz["+KGbz]1# y&vI&y&YDӓN"EEl*:ZIV卒~6r~Հ`N_ՆjυpC% ~ h:THZ0 ܑ /DA5\Jx.,D/lmذ.fuBAAL.{2-jb0o{}x_'>yb֢Y*tz|g.y5s90N;o>ټ}cM5[?WXزX,K/k׮̙3kiiٷoVV-..QRRB% >|CAY[[m0N:k֬=@ב4~Oرc]]],Jԣ.c}Wu@r so.(`[:E"&aI, IO`OLLL89PC/"f,/C\.pvB3VšƾfC ΍G1 /b<u"xUoH% vȇ IV*#k%);) $)ѳSQxJި)\3@L*[wpq~ih*R(۱N_x >/"gɀAJ1YmEB rUW$#%I$aCePg WbADuNYH"  x?a٘ΥvZ &ERV2Rtw<:tzt:'+:[._^we?dFH}{;0Urޠ=aW_}饗lْ+\zxsSSӁٳgc$鬪:ÇZQ,.2Cd̙D=zߏ,+++N7+a'64 :p8$,Z,F SkA8b^@Pk0$Ґ'ßxCjpb1_loQ9- c`F?Xؠ_FE||< XxWDಈѳKFfO9'&rSY>ް\:+KbI* ְ7(UM8WPL h@$Yp@~K$Ua- ~V:T΢;~:`~G8w=0P='|8ᢔEXQDTS$ |5\IyBI rnM6Q',$lAAQ9Ţv^,W [30fiIJK"Q`__= (K#8[O|̅R0|qۿ|3%=e4|/>?Ԭ[ukax_}&颋.ڰay7@uChooRSSg0k֬jѣUUUP666jSEL>=//:-:~c+ Zɓ'ð ]]XXxlv_en[j1̦7JpP$L1kW%U:[03QeQ^7W1 䦢X#/]ဗԳ*,U/7lTό OO>lǎԉ# [AA0q{XpjξjuZ($Q*1Tt:;;ѩ :[OnzrƂz/ű ܐ<>TG{oy/ & fo!lM V&QJVץ? `5I`HKSH;)uhT 0:VY$iXկ3 I*NoIvI$za{y7+**G  $ r/Q޿$'3 .yBFse`{ 86biO_*iU(`KhOLu@bz{yBͱr4(]*П,;8v+P.AP11E»lhըN|CLCCb"OIRuD`,F=cJ<0N >FSFC#*&6$ Y(2|)yEN=h OpG\qD17ׯQ'6^D" oXsQ$ATE#fSU1>JSR9 AĐu}o;z(uBAA1qX˥vy:{3Iz0jWRZhhXXeS]jKcM7?+D}w|{{A [߸q|`g͚uȒ%KFy655 }UUUXiiiшcy 'lkkC15" xh4N4 zXD$33sbm\.Q\ As߸`5)))---;;;??z}Ԥ(?1a>\tv*ۄā(2"|q,8nt_l6y;Q,Zxɣ߿ab-2I!UC/oosDnǀdq@'~ޤ8 `3>zT"Qhta5%x +)RѲ g_1L\¡ɏx|}p٧8Í~w</b w#(A]`HVGf hl@r#ܪb(pHဋ:1 R|Wc(,b%oQ y.yWbaPZ?ȑ|~Dd{&ibvX: *T-C)YG<2zb D?~wcb!a  8T.[-轝2-SԷUݰ̼?܌jt:ݓ>S|u供^9{};}0ܽ{Dnxf̘qʕ+GCNۍ0C30h +KKK &3P/b@; tRXXX B"4>/ZPۃ9*k#0Nx$\ heuvvZfՉ@KA'WԡߑnDXE4X/fUpI*Xyb%lk@}*b@F(ZDdpq Nn1P##?~ ń:t8jmx4\{a?v{Gd1`(U*7ȂJ<ˁVm ע$0WS|{'I?H򁪛v*ګb.ڀNwye Lo$ D/l=7|blTBAAAo .˞7{30 O޸G?|Ԝl3oyrӓpdUwr_^u]. zw[/>o[lټyg}fV^FpD>iGGGMM s͸Abbbqq1/f!Y^ ---" XFCAA`$wTB jĀjrC8X.Ϡj=yd}}=F)c| +;;ip,PCWaJ0;9*S$0KK#cVډgJ~Lb' X|5I*P2zYŧEcمX*4c\rA")))|@QoԏNA /y) #MO'wf<9RūQP$Wj,>W8I P=*6yy!w+yr_t *_FXQ3CmvH0$->1]هO ;2PU=@xzTs^J?EA +6lPBD [AAnOvX6'^KNO].I.|(6n>ިQ.Q1 %G\ e~=]Z`:D>JLMwfu$X.@F`im,C+d%fPc|6%%F2Vi+iWg8|bJv5 $nW9cL>lRuBg`ޮ"khԴΜ삅YDـ0z̳},JGA腭7xK// ud!a   ?[\LbudN6L.SH&Mβ7nƆnȝ}o۸=/D rmMPŶ۪}U_ʫVQҪ M|+V@YZZ:Ltb8"^J{{;nc2|sUͼ۰gds*Q>L^>DR#pC~2Ná>\yyyXk1g:UDR, k * '__PYϫ`( RŞy*,((1)5bX1?L1uXD&$uI7SQ[M(«'UukJwhE@LUu%8Vœ3%?`{'6xAD r^m$uJ"f >\ld7vőn{.::D-cΏfDXwyHcOsJh4KAD4so_|#G&xH"  ~Rm,"rj`2~%)5i_x~9&.+еWqUpG?y%k{Omyj󰥭>oΟ?yCf"RLbeOo+cZlmahIAW@gd TRk.`kUyXTSv{% d2Afggc#›pIIIt]`|Iz;T%5<jFuNVKDѕxφi\7BJIw%Ps.!iHvȎ<Ӟ#5er1 J"[p29GէaN}rm &Db&Dː&Jh0 >Edž-,"A|:u]2 +I{u/H='?FzQUbIi`A1^^z.wHEAANg'Er]lV]Qc =*@p™߾g},=n篜~9glo?zs ʩ+((<'N32jڌ|>gr ^Cjb] |qqq)))ɉ"hAa ܩ]%)<b^$F?fmmm8hd&p(iM8bHMW5*l:NY'OJy^6[H}v&ʱHЌaf"%'xz8= ~~"gkO} j#6r 2#E,y"i)zu7*1I7OSiW\W,r d}+)  &įmܸqݺuZ7EAA/qX.vl]=_Ĕ>8]x#K K? uZgf^Uw\uB?O7=8t˯SRRR:::`,&fYPWk999|8&fA]׏¾x<l6b01 ^zll,*M)%aEAhI=!k5VR@X`_C1`a%_;8Y;>< ^,9 sh-̈^2-P`|B::-JLo’oP~ U;V$1 }NMpT8^NC{NehDoţ K)t:f QE_G 73rC>ȭ>SrW!fb_cu@_  Q.׮]kZG  beo^b.op\ǯ}nޠ{nᆜK/^u;|x̟_ y>vƢ7 ,Tx1`>YbPr`$̎ ]+tA0.NfPb&r[V`Wc>޶`ER,'TIYP_5IPybX.K"EP iCbqIbVԃu(V(AQq`3|Io7,YxML:(άp-vQ:)MAA1_QA?^fM[[[ZZBAAA\˴Ȼ\j{՟*_Z^ïM:i}q~HcOyyyIIIwQOq8Nf0g%T;g;Є`rUbbbxKeutF$Ы.كCH+z)99)aHMMLTDE%cpb,soI¥RD:ԩACЅ+@RI#eŎ5j(eiőVw].=튂T:S3MgI"K^{ZJc;sQr@' v+<L4 ~~Td*'TZW1З,2YTv;PqdDP_Ѫv$AAOd駟y͙ԏ# [AAADȎvobbc߮~;vkN3tV(Uɫ\v:pǎO?AGkg6J2"{F2'!a 0)))11199955Ef2|+`FcJoXdv1pȽ%KKZA4Ꮶ$ %jh#8$zJu"16F=ouR%Gyl'ɁN 7,_s"?mF>(z@#QyL#ʸ!ɰ=Όz^?$?]#   &v0i5⟧   V/IkK]h͢ל M;mӿ~^Ѣ)ECh}6kos9G#»郼ٌ7k8ѵb9tK&Iv666Z,v_`%V~L7U)A"A$v\đG.:$ | IR?,dUs?FIcuZ9h$ݒR1CxNKN5r J~Wa>5I>%SpA˄#OjIU /'ԺAAA8 za m [AAAcؘ`@V-+/[n٢5-g4!h~ԯ}k/=ySpvȔ)^v}_57(JzM$5oթ(ώWb(5yR1:䦗J'Q2.x{Y]%qzI"S]($K[&$Ғ$J$%^ǐlӧgDgQ    6xkAAA{m-;} Z(٬;(g0)4;Fp"Tc(?ĞǰjGBb Pݪ=DҨ_p:\KH4m[C=iT u9LG*UB鱋u"Ix9y'yP(w2|ܑeDl[e 0% $ooأʲAAAA b   `좮`,XQ_  ޿gCL\XnгDD&\k0Iꒇz~IuuݴyR2SB"qiN4MSZhGʤԤs.?'%=ZOvÛtg|Vsf통NbGvϧ{=O/^rΒzBb€6mhԄ7H4atبL%ddcEGåTdI*;*_Q>QLQJ\ }ÇbRBL ]QnnB[J    b,BAAAj!>@UIK: U"ZیIA0$(!|`WOko;'3l,5,`WhW]]^GbuE_ {[z!! >~Ek`ӿ~_BmkdX I z_~s7 _+?~oZ[ל~\b+ࣽ~x̅3W^rd6MW·֧O_U~sgd)     -  SJ(ʑ$YE͈E-R|R\l'Sh?XBթ7&T]}`O>b|I>9tҔLlYMuBN(J*1G{2!X9|?| aՓ4 t4+ `n>B!.VcB#l(!lNJ(!T7\ [XK"a0}q z,8/>:D\BU:GaGgĮ>\xa}Pz:=0-'ߔ|f.yI&PQ=VPZV'Ϝ ecm#bɻϼ̫zWGJfUglX6{Ͽk4J     4$lA1@ã#.O>?>K46፨AlhRR]}Nc$QLPAJ+_OTCA;Y#M=E}l:TWZEWAl v;ݝNaqtP[c. ڧON\     bEADtuux-}$t:(+w ]Xė 8k2屄w,.f N<#GL,N\(vn%* G, RSdxTѦbJcew;= cxc p6d4&CBL 밤:.%Y &KB ސ>*MxWv[ *mX\:Vpy˜9v ۞y;|7.__~U?仗D6^}Ռ%.d3gɖ     H" aA%Ze!*N;Pz|N "D+Àra^9T FAAzt((!e f~(Ga!/jB{KVa;N;mή`х W&9ɜ*vq1iEp:T”p(D$:ٌ`e$d &%V},`0zRhDY]ewuw9s)QͰJNQNh}00y}9ybe,܌I+.\x?YYم~B)λ~yi 5 FO?!ooZ}-^nӛҲ w:;5ݽOZ8[_{:&KR2R`'.}s;@AAAAAJA% z݂q{F(I(mqyܝnO+,$U004`ukzi + To~11NȑBMD$kF tC=u&`,E mm6kjFt-',8JtvwuCcRj錰}WKؕթWLɊ2QyDe ~0m}tl?\e&)1%QXRѾĢiH28Bg>U԰l6{cu::q3zA J8`s`2mXyķ{WdSE` Y۬0`algtOfb `%&AE(E WCnSk#%T{p ,'zCMCwWV..(-,5+o o۾n~wsÉW9\9yd~I~7薶6̉r+]yGѤ1PJD     bh;Aİݍ)`I)NSlCXa+M)N n!Y?ZUl\d@*;' dL죀 !Y )VF=T"F!V/MFGt:T a̦<.9Ԅ$lFa*,l@nq %[VlGm6p'}!U4a,%&(| Nwuu?vOtO6iIWJAfQ[7n;?9 J zLJ_:t?bū`l-?pL$     N=t_ P RvqyB-u鲹\l#lv@V_ZNcT@ xj}VŴ® z:XfN.~&b-h\Wٔ 'ƇDk: ?v?v2qr`\eedgfdfdeF)KQ洶Zۛ*b))2KY:qWG͂ġ0=0{ V-XœNIt[0ܻel۸j_g.W7-;oYє"ؠz5;^{/G?|t,%     b@Au:P.,veﰻl.ArB@W`EX},_&U&Sd6%$%o7,e,)~+Co#f)β-jN6ge\mkq8 isڅF 5utY4='=-;(+9P ԬTHwv,+ -0xmW02RؒW׻*ZPr< 0+V=(*`iBP3'/Z[/J̒ĄzgLJ;6i;M6iٺeKY޻6ܕ__m~wϢLAAAAA$lAjtڜ.KHZmB(Gas!t{|n_WWѷv(_ JbeX%$%ͰD]1 C1ztewGs!ҰzL,Qe2P3r31] 6\SZ`likj45[8efhlongWrzrf~ff^&ӡ&8`P%V-|5s953⼙fUtm"D\n9š{By⨥3&oYyٔ9Sλ⼲9Be,þ͟I|I?KΜ4uʳٞNϽ ~} 7w iAAAAA# [A9VNabo HڬP, z` (q*qx R%VkbNJI2"lES\+b`pgɧ.F\Fb(]%&rC & gY0lmhmmdKS]6[>6+?+ + {Ey!t!Zc(ZԆ֘)-+M-Z++/(kef*\t&f7BС=!I & 4I`]yԹS̙?9\Ukǯ}|ٗZ ?pWedD 77Rm3:d]_?,?9      D~رcɒ%ԏ#Eci4wk+V:H$64:mv i5WP*QHLILLMLJMJNOĂ!MA+bd$A"!-`d”%CJ\*/D+FSMuM'kDCCM4Cegeft*,hoi>ZJ| X5y^,&6&5+5#'#='] -Pg2\ׁ]*wT²~[h+ɛ`ӱLHMon VuYgʢOvlr'}AFk]>~(`ҘfjfD      <$lĐlm6a6677 `.H|Hvg3dsbJbRZRJ%ʜb6' 1`(AbTx($ :NyisJ+]dJ",FgR䱓c(Xۈbިϝ[ e^qTPˌ31 'e J^da.1 &.9P•hLI0FC wwugd^<{N|_ܸp&YvɹWU!Rm+ :]1GQxWOj^U$EAAAAA !$lyH"zBVk[C[CmCZvvn4伩!dN2'&&'Ò-#>H9!1.Aj͊Va SLظXABl!֡_)f6װ ڣ*RWU ||efOYJssBciΠv!e](eJڨդeed I0233E$%S7ݹo۾[²~ g^<Q*U#5s8w5C>SNv;csÉ[we?l0_H"     <$lۛ-ՂPlinklhL,`b<.eK z!9>!9!)UQW٬mP8:ZY`h16' 4&6&)-)9-{b -Bٳ*SaJ^tzN>Q{#55k}O/,+,(-+9rbccitMKXc_UNg^fgdC0RGfP4YЂj_ -7w%%3KD(;o8x.\{ˠ;?ڹoMgN=_?,\0EAAAAA !$lyH"&NkZ-- -Mvtz^\fVYiiYY9E9مihE J6[{sjm MW|_TiQshsKtzĄqu9?qX\cbcrs'MT4KX )Ĝ_'1'l8PF .'I0'r_EVgӞ]r50O6myu1. n{[O0~ν܋sѬEN{ޖ|؁c_~O^jvߟ?ًgN[qڐ완-     b!akC1RRsX@S^fk9No7HNV2'ҒR3ShXYŹBœ䱒 N%."YPb]oL,M,bP^ςm&{gcUUVA KjFhOHJ(^ KɌ2`r6r<~h~* F}^q^^ \)F]7|45d7.5|i3[>ocnmh}Wz-5x5F| [N5k.8٩|'{w}䱓K[z͝EAAAAA !$lyH"nڣ*!ka[ciz!7P)++ZT<8=;""^f.¤klJGsJZ^m)5+fYZVZJ &Hv 5kVfzYKgB),3'ggQwM4t S^ 񑚺u'껂BGYt!;5X۬;? Ov[-q% ZPcC۾磊^ϫ_|%m흍/ntt_5+`)R4|XjaVWuZww. [AAAAAB֘-bx[[ZNe}KS]J]p}~G5&Sʝ[PV1i( Af2XZ[Y]XmhuZlˤtX2r3P̂2-; ˴4h*x:=G+/Pue4mҔ9SAY:40j j8t'<9!5jB/E۸hjQZVuRWUm?ؾݝK.Yz҅ƶ6_^ymmX.;sx??njW;*Nw!hJN,Ვj7QY<>8-{\ DA@ pC_:G|uef/Kfuk4>j;BFٌc'-;-$/(ט` Hg+^\:RPZ0nĨk0`DϵyyŹB:;)WoS 6뗟}/n{p>l%,3uT:M@.wŶBNSoO7u֢Y3̘>zb`7 9ٻ&[ " *poD8{VV{/[q# 2do6!PoOk~r@s,ۻ uc5Q`O0i82{۹޶)g}䭉ɡG&9q㮬,8F썯bEYE::?/hk!+'%';%VE^5oH&=uu ED~w5rJrm{?d{))! 12A9*_95#,ZɑQRߧWٓ Bğ#^EDG&G$Nb`n`dRYCdi i>>)):MrZoEy2(~ ~rq#Vީ{7}8àWVLkjh"MyHJOq23Ӌ2p[_L_ES[Uw:Vadb &)ߪ'}'糘,q)qCsC295ԍhŴ mk<`dSC|Ɍ{,VDSRst0EUEćWU6tm緑 “.s44̍jKK8K*( Xa Cc}cԏɑJ-5t5LLz546kSUW>  .)nbl2HQ+6L[^ZVRW2g:tP2-x5oĦ< A&7^kO"o.66xxKDʚ#GUnnjsΕ}W$ &p&e%emk`Ƃ)Y)$S_A窮NM Kzle*k*0li/^xLT@ygæ e5O"lvFRFlPl۶FKHK8qf6fX@C0̄`OR V[ad-&.𳆺W?:('%ǰzg7gM]MD+vw/1h%t9HHIpuu- S7u}]! kAginj{&&* *Czj= l6̓7~c?ࣃF`}BA[uY|?~w.&#ΨW/scȴk2UR+ 4ڛo;u3{1Ɍ|~yȳaa G4j?d~=5kA?n`ͽZpqabn0[e:m\7 4ɸnnxAĕrY}b|@oTNxnokͲ22  rBg+WD@c[-( HnQ\y-2Vt-pӬ%w n4Ls}]_YonmKmMlv_ itU#;Ǔ MJA J H=7_@45މ =ZWa1qD9v|8'Zzb/Yj5يle^vADLdᭅ NBh˜&3?F.t $lt:s;&ZdQbJ -fPkih :p88rr b2oF>sg33/^ν[O/]?sEqˡTc 0MMVߋ1AJג>sãeҤU%%1p.NҚ"9jWE%EYp77\ScO [ps7mK fŰ?lk5lĚJ gΐW#UV 5`EZ}^~03N@VgN ޞyj:aׄs^W MD=-'Y^nF9uS3jj>o)#F܎in4n:|ɖ)ScOI)I-y IϒXYP9d1Ȩ &dŮt*}A6RUFXzZ&\h؅0:w\_>_*Lq/|Ks.͑U:&\|ywI2<:Jq5c #x PRbX.ԕm,!++I)u/-0V+TBL8͎{tӊ܊ 6FI=zr QrcrNݏpX0dEE~HUqYsr>tPc}egO90FwC :L~q5G1)=.zw>$#$cCEmE4^9FR{C gʎ~A^l UT T5ǟV5Rwe6;Gsr{X}a6"b"|O.͸$(9z6O֑b]tf[LhfTTb-CH.y]_Qy[ϻ:O.ZY;46pwXdT_hãq&LmӶFL][puDEnXz!4DPIC9!,l6oO]=.yKjMl}1|,b Ahi]~le{^[pmʡCy݋c;vڑi b43^|j+meϖY@L?8a͛5rrF*-<;Aý_47_{%YHXxqϽ2u9!-& (j a 0<7ԃSfEfOCsߊ+타pK4nĚ¢ta3E4Q~\2*h)5{ Y ]eA鉧WYm<ĘkZZrm5e sR3Z򢒢Ho)WSW#]~Gˤsڑi3l%ʇ𣐈P#ު{"/LF"8SMi={qݬI3)h) & |6HHO?.|;&M› wj)YU-[uy[xv=ށ%jF J}~1\|9&7:7NGKEEIxw tk/3g3O']rd4ĈKpMlws]TuSu%CH{%߅_ ̯4b4\kWθkqAaX~|\2*2 G\66bc_]{<\&[!]ʌC[jjլst",~9撛yv&ϯ:bu:̴ _?Bf?z.4Y;p?>qz J4RVx믮#V@@8LaBCsSgәgg"[ GvdvVXֆ Eimi߯vO@A'y}]x/_z1LA{榺5FQ+!Bʲ  ]ϵlÔi%i4wY.JnܬO@5k-bR]6|pEmEGz .ݫ_^ѩAƼ~h/+oy͗D@8PKnJ*Hn t",LLJ aQYP$qEE`޶T-GmCaw>Ӈmk:;33;L !$lb2NDhku0{8=bh5&ƍ7bnL;i䦑 iihNw"{2I_U]RRUTe0ؠ^/VV&$ ]9s礧I:l)Jo4ji**:t>ϋ+!/a9<,&+j_2$ڏ:ZG<.zC}ͿF&mq:iYjUYWYHD] Wև >L-'Z ^kdɥ}z(*:;,- Q*L*~N{>$W+=8=NIg<=3ylvqrqmYVU2䘓ޮ&`2y1cY# m0ww>80C}'>I\%WyU#Ut-OHB͠ )$*a芡%=/EGn>zi y-1[Ԍk [Wik;ĤttRSB΄yY_hOֈ#_(=a+fXNʉAy-VTv _}| UT UOdk>kr[g [/#%?OVW8s?,|{ceш'xR 9 45Xt#~cA|{c26>j^JW1PeE$R7UoFJsbfHٗݎ))iʡx[Z``Cc{Qیο6_bbn]uw?Nyf\ĚAL$DZ/? wB_ -;'!'_x=.x`74Tz/^#z׷ mmy`ߟ 3q^LFҳǧ? ӌa@yO>Kn6Fl4h|>^wyͣ--禜גsiN~WԫcMSHb-Xb>|]:!Uw߹sAǃ?n8ދ𺎕Κ5 Z !Jiz)OsBq=jbvgŝ jGma!.\Q_UjS:K.7bDw=?`Io.YWVQIN Z&<B {7w/5jftߟcRJRBoc43g{'=Mwm9T}60l0îB94-( Es!Vk!v2xop2 9mO~zHaUEUZ]];1[!gC"LquȒ!HxvY&=A'ȜwJg5*,&S= ?,v:֥%Rzg1,3{{ 5A@8M}e o̷m\_A[[Zbnt9WVZjǧ?d41[8amn5ћ#:F3L邂LڧOGdI&F4 +H(жF(Gj@ɽGo-!+۰Ɩ3H)J-mV>`݃ ?O m|5E۔t,$lH~ǧmfجxBHu3e!hYa 'ǜ,.[vR48Niz[[7ۨcYU\p8 }>y~uU 3 6\\UTE/kɷtuf>4ל}xFHFW󄌷a͵/vm;I)I2isErK+% FߌLO~l1b**ɷ6Zyn֘|~[Fw'\X = wFGGhk+T$PD؝\!7&ẇYY,'~:z4Ͳdd;:_)$,Dzxx%7u/N?6׈^7|s//aP֖_HoE\Fk>tO=M]rT(_00?7FJRJ \uE*::(1|RO%ӄ 4sE;xcBBQVU* *t1!gOﭺXH=G |gIO?u?'Zĝw>%벵~[aU7[Hno=={ZNE^TU2v4FCO*.;:⨨urrGa1Y>:4~q;! ЕTz+-lgN;Ov1,R8ʥ.k>45cKDgH 5MbUf x5z鰼*UJGi7^t6cE# ji22`2}** ^kd|'F3´ JzJ'ʹѹwVXˉ]/Tj^| [ern{N H8wSxr%䢊 [3 !]vdŞ^^G\sbZZ6t& _#'*Ƣ9~֙2׻ŃhYmq:|XDM=kDq;z1EZMTJT^Sk0̀/vP1P`4I%%6++?<85z|qa1Mz*! -ZZD%ETtS&L=]tĐ3!-R5e΋H,Bt'!a CabyWKKޅWZVx!C!$6`+ * =",KBZݦOLW3RbntqT UVX}*,V+KXwWo-T4{.`RU\E& V>(/YR^?AS3VC~FA1g?=gO\V?2ZZrcrM遫 F݌:9ds}sUqՑaG(^ZJA F{}SR9*-o:zEt;+9dF.dku 6}eieǧInD =W\[ p˳/2h]9͎f0Tz£6MR"")u⪰ aI}EA#7XtnkSg,[ +x`fhMbRbP߂Kn:wX,VYVV>-Pl6;Df+;T T Z / ٕVViZW ӽ}iZZϖ?7T5:zIt;A`{D(hi~ĕY'ܥBa+I-ytC}*M9g0`)UʂV$lCp":~JZPclC⣽;ub1YrA4}|#ΙK·}i򤩶IZYzʡpAAAa1aF3h:kL$K3.XW^նu4E6ne#D>GAӤl3-q;UQX-j^~"Ho|qVxrwnOL͠J*JbdsHbz~tQC{Գ0[yj&#XЉ A!f[[O?]W^(u5ByL;U]H4y  u=j.B^K')I)yMq^|=nLuaKD/fftwZğAȫ`T G p+Z--0oEH)Krޅ=߁?/vJJ|>  XS]Vb>g u%:+Lֵtt:C}KRJH}V8 3 C͠^#(>3 ncO|r򨬯.\*\(Ebe(aQFX3BTBQz55!gCot""üX;n'!+DӄJ9Q9Nt^L`Nx,0DŽa3ƚƳj[jq2i !a _øbYUY~E-VHDHJA v!Za Ŷ_d?a' ^lOZEeː%Ce%r5|X ^ӐEB=S=lc54yl66dv{y}2'n5RJ`8Vokn.($f{:ӍTo,%Hdzc0{(H*H6T5UMk _d?t,Cn.jg&ےfWY|O-trlOb42b2bMeeɣm2o$(UT'](B'n'#c ԕ=\q#$0urv,9e }xݠĨ%C|*,ƭ9?.?/&/7:(,d RtLTTM(h˯"Rm e}CfUkKkCuC]y]uQuUoI`Uii[@HD|=grMiz) 9rrjJj+=0jA@EYOYFU:e41&1/*k.KOysM{l[P [#=6;2;]6ide5{kb<ĸ-ŪRPOn,| _44Qyodd,'XZM"# lvE^Eb2gڕ男oJSSӐ0hO"jdf+-sXWVWSZC/gǜȜ[1)VCBVBM@]E[Kn܉uge/,.KnfQfPՌ"UUs>Һ)b2Gm9.nqi7z)34$d˨ΰU葉KCXcEeUeɡi_57Sө?}9}]/Dj805b󻉵c1Y]}P]T-&#fh<|=uHK~I*j+pMܼؼsa/~z!!/a:պϸ>ߙ¥ZZ>~&YkkikJ+IwQ())r+p:^XO v105IӘ17b$"2'2';";/&cqr:Z}G%;+諐W(B+PۖRʺlm*}҂Qd=-CF+"㢾VW{yaur}#'?,tuպ://N瑰 [ХhYcDD7oӐC@< ńM /gxשy1y,&E^#z>VF7uC?7R 64ioj?UCUBѹ%-m=d]:{q};/;L}9-0-ihs;vj^ -}}䌐֖VmKm)V$8RR]\Y5YhNm[)3,3/%X MZN$#BBNB~[lYaYՂBmmէ-͎׬׶&ǗWFܘ7GjH$s a&L96aEJId0Iy_n=הǠ2--޲lI&=~IkެQq/I=7:$ wFGGhkcT$PD؝4amUVu2IK/%ȁ}Urק]<'GnuN:1ȴ^9ZزRj$M#GT.F(! a&Uc aqK5zRO%//~؉{}Uڦ1C  uZ`G}̌$KK];vƮkho֟`,,b;w5?؏26/Էδh!&%-on Áq2.U::z:^_U%$X,z9ҷյѩOo>N%5%5rrV3bDt Q}vLݩK^Vz,|9nxXaR/q?N7ޮiy^^뽤-Wxw?}I&g [e"a,W_z(x8G[N5P3bnŰ~7b3fXS/'?K4oЈ5#(`9kKC:sRgfFw~ҝ&ՋM|(!a V2lHFz譣Myo%%YlSS)”ޣz[M3OoX  $&$(גa3x͔.ޤiC<q^4\`"vrd/,&!lƖ'"6Jr` _pp$f#a 0Bzd9YO1%ڮ5 U af+gϛ#o9u-G9Ay;[feA83[etMSU[V{pAQ)ux/õoս;Ŕ?ZZ֟"D෶F^?__1x 'ppMuMwW%Ehv̍sgEj^zt"g o-T㎊4 =iI:$K,&+v i*ucK|()7dɐA)h)_{´a IB3-=wO:~BYgͶCeeyx}*3]ڂk䲲j-!V.Ĩl Z_C@E@mnIb43SUZh$K_̆/}31wb&f똡ˇ%OŰ9h[vFu\oމ%[Gg3,|z<\MF3s64jUT9t?=Oxgiѱɏﲏc43.ͼg^?M78lհeURN?>Dz[rEK3.uc*/6o߀}bba3mnmj?`?5ʱ,-?hcݑZOBNL>;> O~wogPQ)іn-n_ʪWllnf-Ca]ӻ+Rө=ť9̶kVh-xQ7^rٙLJ55A57u"/e.]_ M7ya.]`2]_q?zp*i#ގg˓'rHrr ;?P}z->&"7?p4K=V{X~yooԌ~|^#Wwg 3\ɿ"$*-nLz{mzpDDxB/Ͽ1+h42-+* a :\fXlt_hh|C{C6hbs4tC&?v^zOg\ş ={ lv&N&<v1 CF#M=}cL?6fAW]-X&pfoM_]cW.ԾaN?în:_}}Ttzi^-BM$&% qiS2[R*C2LWѷǖ- vJΖ 斀W՟wo߬^+".NҽȼMfp5T:6s18n)3-@tF3szdɧ7:#O=[h`ùW O?_UX5| {&**]qp2Fx{;o#)/سC/9<#}6:;kh.@.kެה?rFlKbsGVab^d,l0d NEXùL󢒢 o.[nj&UH]Y~4󱧸8=SPXYXIȯ3vX'L_d{׿m!})".2ש]ʎ~AN]oOe](J.mc.ӕeWd=;L+Rm"Gt@YWy{=.B~܎ij>X([n 9 .*6V#$lA݂ M3f*&#,l3yM1[ WW6!pgcGc#G϶?3bdj;諼;bX^7~xHV^|qJȎ=sKcGld0טּsuU2 VQAt˖,y;}3FTskKڲƚF0B߯0׽1X@4:`X 'aC;%ѷ]!dfTWQR^|9D`~xs/9߽c~#&%yia=Q&[JPP݆Ke] QVQ'lmiUXQ[PRA`UYN '(Pn(BF\|툛tq ;SvvҶ M G6O=aہkbԷt'/~ib]yYXLx9<\͂Knlte}Ѷ#P/|/-p tۙ!+bX 9n;lvg^&G]y1GCqc5%5x 3oy&^|/^r}WJI;LvD JwEf! 52w4ۙ{ToGOG6}hȡ6E[FK>xڲJW?鷧~Kdkq?= Zp$ֱ씳j>\WxZ&MDB{U_QBS1m.$u3Ϝ{doaюY]by>`Q }KmYG.JܩOKFOWܨ\!Q!=;)};}m3k"w\TR07:G_ 33AA9[s.5נy_d%p]j#CCn'KH댓G\0]ݎ ^0xkwWޝr+ٕs7ה7naI{l637|s͑aG lݪK*#'wIw2jYLEڴ"nfPU U; a%Zdy)h_w$!!ۙW"lvǞCqOxBAAAqqDBN_d]y"8f~İcWEj&UYOYDLO:]X\:-ţs=:ll)U}3VnHJRKeOhhog*|]QGysjcϙhQ^L^G":4xğ'.}}^QܫC qX|q>Kjj 0B߬<;kht8GOǠA)~)N-VNCSKle R $=OSmmԌ͌˳.IU`^jRͪ*]}U}XeN_},J.r^L^Ӷ}KcKیeǀ ה'7T6t`m-$jk5#E4XMR3j 7rs%$OI %uЫUݏ:cȴ[)&-kOt#GW)ӬɟeΉ1bo%"#$#?U^K~]'\]y]LߒtFLƚƱ;u1>=/s6߄Ԝb2 &[?_s&22`zZ2&'ff:-:leeQY_s.Ǵ,ڹ)Hz%NZJ;W}.!F8a-F,ʜ+ʺND4:ӠAUzo.#DXt#'2홷Wַ6jK>גW3Qh[>*=8V4N:{{mVnc={oyx㜨k #@{oD%-[:^ukVku`]8@{7Əw }bHn=sy]t;:&~:y pɠO630n\m+m􌔜XsE:D@n [Foaj, ?JzJeiew'_zȩ5'(h>qq#|jμzpq6>6B[퓇0|p#7#WM$З8nKZ†AeYr{ }2^U]waa|ZVз&4A-}ߟŭ x\R2<>ia_Wej,ȿsQ4= V^;Ԁ81jkOZAJ^\pq_S&;8Nu;W\6זd+h+lܾ.S=KX&gTT|q(;`} П \g>+-WV6b h jiNt{ѩX{,$#qWƓjI:͖>d9hvБG+ҲWdq0ihB|]pyggg~]#& zL1 *csA}LiJi¹ρE% ڛ۩Tu s+} UTw 󛎍NX-K-J@EV7Auf?3.&%M8jc󯯾j[k?;LD3 h*oBmUdV|\LlNL8ao!aP 8Wf=5 @{K{o!{-U-vzgUTtgID,3Le_O}DlhYj=h:6EDETUbYBBK/?ħ^MeP6TKB/7r5?`'@\:MwҳדScPq5Ő[$OMJ4"h!ˆ$]HJ|\Q`Ab.JC0"h'}^JNV"obIp>:JYh3y^/%/fʆ/?~|::>ӳNͲ`7]gWC:3L~lgy./$BkYY"Vq{{f< ,姗˯C{538eX :?缡!~\6:7]UUyrL o?˜ta5)կ5gwa8`0_sX29uÉql6H.J(8- ] YtVIr`3NM Ȗ ]645$yjjK xܙ 1?ok8Ms?sro&rWjFVKk}:k{6*|V8Ȕ!HI--K5Ǡ1PX~]Bax~SVy y4ۗ(^j'SOƒZCgÏ;'81|Omn};<BQ?rȞs8wb໅ [t}=+tG(_tEl-w2޶{ӏMG_&} C&~-8z a |75a6^5b&R'TRpOܴl:6zɸǞÆ Ec3=`w($,]%_J\9ˍM&p(,sc nr\`B|Y%/e%*+^aaeGXW__sAoe=%]%~ջ>^ T&wrľi2{jtgwye\3 "D`%ӏO) % 2˅s!V_rY5YUO`D!8Y܌3V<\A!fmKSK5V7Dh[i ~Կqa ._3|UĪؠ gプO=A66hvBO}r ٥ [X,9H/jh_3!0w66'(\Tsy@t0&rNΊۜʬJǩ7q MMˋ.pȍ>E/&_BOrDn#n̳'tXF=zY'?q9s5%KfY q,M+}7GTv8/6<(JzJ< x~\~A\ڞYwu +tlUɩA0i,v;ԙOrH_ A/dV>Nn:ؔA+t^{ԔSV>Vnxō=җE?̸R?|?sAdtB譣ei9贾qEPa vΝN*zٳgB{I&ƿ׿/hLWkCIL޶{"mĠDv#G$ *zz= \u85uP(Ѹqw2no#SXԟ}TSJhE1ה|qvX6l'ՃWZ"Nmy82vݬY{ 7>^ݹ.UNM=5rHeXwݘЕ ̏Gc]lij?'/% ? ] 7YMMhJnnoz5(T5V7_eܜg8Z4Hm2e3v=({Q+QԿGͤ1WfvvY'g Ụ['kQKt!¼ #7{b̎3׭^+b7fS]+:V%EUETa0 Qn@$"""FqA"""|z}_Z5 v;=tYjَ;%ysis"s?[e% AsKڊ?X(**ڝ?l6Aap)Db$x\aB#~4ĊAc>weL ˽tv9t AP?u_nmܦnc9d=t"HRSEf Nx.:Tׯa{s' z&V +""Dx{W.Yǡb+|}ةT,swLL]~zvםdu;HT{GEgzti:+*odA!=zL;:WwXs1cBVl÷o_iav>Xdi߸"Baɶ) lE%D>;]KHYXxߟsAW_Uk3Zbľ^pVyUZ"**A| ~ﳵ >j5 5b%.) xAyzu7Y]7'sM$$,xv=-p#Sz0[ q-ͭ==4pDVҳUБю=F%S^"$Z"oT4Rw>9e;wϵׇ3[;334  ]M֪̪벷}3^fkk)WS,"n\|xs/ 8ZB+!l3ZH]AjГ}$A7^L?6]?g EmVÛ*Ԕ+Vhk<B##B~W޼K?Bbfy\'F#ѹŊNg1YT2U܆B}A5hBb؊a/K N羯6B=*F*o抺'ZFIe Mn kqw:qcݍ;[L;6gO߾XB1쌳h٬/]W}~=^7wx[x<~ #xY(+FZk{qE6͓JH _icydđ}ɺο\"xrw?kí>s|qq6,c5#WO'|Yxb9""7ޮȬ̇sRٲz s !BcelÈav3zJ]AaV]uU22<ɸ]̇VVjC(SЃɔ/+ +!<fp7 Ul{C}zJ*|r߻:!fЫvg1cƨ?؃*E*E;D:O)? la--1 lv=,m> C`{SKɩ!mMmZ,kʮ:;lSyS1y-!-uk ,&+x,zcҴқ,+дs0hRs,&.0}Yv5q8~| :Pg^3OH~~y={7˪͋;2?&\?]nBzk z [XK|۵ R<@W  BҖ]Z̻8]_}}ֿxxdqIq;ƹqI>|8 L:3BRľƲƁm\ϞRSyS䤋I5F2ytN 0`ʑ)**4V]wߖMP/XC|:;,;'2BQ1Rq pň^!P$$mp`)WRP5W6{}8N|GGGMNMa|!wk,mŊ"גxOP3ӡˍ}4^&^?r!KؽfNWeU>3M< 6S>*NM=e7ɮOfk!"BD>֭ [֭KHHHNN8 Ub{J+J\q6w3}^6ۍǯΩ~QTCU^.\j0Iu1GcZ ?l,(*~3=br^l^<%F^]v{7dezQY  xPsPb1Y%%ُVY!&)f6r(1kjo ={=al'UDQ^MQWP6mqJJڴ6ZiJiaBaQbQqR1"4t544501r5@%D\bPb[S 4 0JK5ojP']Lj*kˆaL<߰~XSF3,_TQ\t}я^E%y(hi#\2ox`P7IH8W `S [[ [ ,--8 %l%%\ZxחjYjA7NmzIJOQWP',58U+0si y&>~\k+(%Oʸblڸqe#,+HTľ&9tPxǜAc$K 3XKX1xea9Ȝ7oP+PITUcUKNV>3syz9 25`'f@:<09e3?R [#E>DȨPS7v7H[w3I$ƃrЃ+%]HJ\ll6iW)L=ZFsXN(&<;,\HG6TFE>m*ŏYx[XP7cğ;0JA# ԫy1yxU^2$r#44y $tt\8yZߔpq;];l6bEh}{!6RM4D; qjn jjNӝ\fj]VB^ Z k[W{zƀh {SfBw G_-HI ,xyr1}2/-搵k{ CVֳg TUUz  hYhI{z+Q[QEEŊeCUxqE:yMy7f.D9Ors"sòt8Lv@DIx>8XA[5m4RS*2*m]f٣a'73fk\6yz5y1y'c%.^=ttϯ|9OJ's|;b];]tptd.<5ojP3ecűV\\m|r:  c07@ϭx}Z iӲgbҙzvz#-L|{w6!<z6V^E[qr1Q1RѱQ5QU3QC{Y5ٯ/à2Z (ڨàV/~]]Sf x}}Af캼:RЕVdV, x1:LNB=(([UVU{s;zRNCNR %}%4@u9C'+>Ҏ>:ń5IOJn(FF=XLHF]uN,N' W6PֵEUVM5 ܤ(295QrhK+Jfv ɢL kZڸN""РFJF[ۚ5TOJ NITYf9nsݻȮ+J,:1j+h)x`=H9As`5gs]&8l4/ N&-|yF=rwi- [ [^^^gΜP'ly<|G-_nF^b7TTtk"LBL:.Mm͛B\\̤2;_#)+)(#(-!-bűbbhðltŢz=|;z"ڔtTMT5kjZh OҴ҄ WSim46ܭFY $O#($ \\Y^XCdPܗa18YNf&@-ŰYl66MmRη()hi9 fu'6NNAʗhBNIg!ڌ\zpˮ5W5WgWs~:SwCC+ƅjΠ (#4wS2ZVZ=B%SEV_P__Xuuk]+.MKMqSziR= uBth.GUC$[[ 7-(N%e$z75z=qme4f$*}CѴٙ&%b&=N/C!YS8o$#[Xο2;J|o؊a}@h'_Yrv*9.λb{?zӮqX1t - [ [K.~)6a*/ Y0bۻ|~kiO % 7~q3~N9VBkKuK{S;7)tNl赡$]N7U=VF7KFIFA[km-ϯ8D O{K UE'TUr9e z~3]#0a<<>ɪɩ)OTɪ˯˫k(i.a0 Z xU.^/%'@{ i ) q)qR_P6'[ݙeҙBĤ14sP]9oy2im΄a}~W^Q(')s’xIUcU't2t 崝 F}/toV2a%jB6㧥*(ޖC@C!e?+;#_UE:=As:%N2'iL`3y-y4u `/m.&lλ_5Rl'ڢXCL%7:7hN2"VYxCà2e?<^Eb/]F삫 tNuuΆ0O'^z mgfd3Bѫy?s,w ?p1 Z|ʢĢ!/+/ [zzz<+yEc-}[҅НmRG^3kYj i d%^Q|N^M=[^c3d.8Y,f_?z&>A'gZא#HuBPLѹRהG#!gWTK{-&Żڤ}V{ gqC%Sg"/&BԵE#jh55E]E%]%XkmmN~~J[ |oo*A&&P v2r5ږM˂c6l*xVpk-Z+MRVURT6PAd.adq'΂:ϐiﶷ};1( 1LljbE$$ŸhV.f'!ϭjG{%8̿<ߞvyZ+h0;55 F[S[VhVƝ\ǔ4ח:iAa|!ښʚ3xU5'Uf$Q|TBsOi7hk*oBlknCtɅ|2]۬/c4KB::Rci#P_WWWɥc3hssn+%e$rrwOߧ>=;dM>'ӈ9s{m[_l_Ft!Ic^}6}vY4,ǼyCHWs Qnə())122z왇T*E*E;D:EIEZ߫?ijȍνb{s}<z~V6]$uMjjI?I+J+)iq٠MJ@7I'.&)8 a0ܚU,N=2Š14NUN*Aˬ&Zq62'JVDGTܙ\ũv3  ]׌.y^bŰ1 RQn(kG'Ί{z`mMm2ڈĖ k[P@f8u˄ꖓN:zy/3|қ7,zuԅKJZ .|V彗 FF&&6]YfhfnunDKg^Y{;k2r\qmDSns8i Gv MҚ۹@F3rˌaűƪjfjZZ:t45xn qq gj/tO Go=zhH7B!tghJpʐeC\\xn_blcF膻u""]ZJDB7A-CCC--xH rkg81C^E0X.{;Tnh"Ւ zT!Q>DXq)q i q%#MDQAzmm{?ΒW,YNg/W_)M)_1柘?#,GY:Ms2d͔ؒy`c>)V>V.ͳcDF0Hus N?k,i8f!}&& gl]ɮ>[6bMNhY~YAz;wbKgs򴘬gߌr *KOk+h+p)($$r<:t\w)+vEb2|)P;2dōG7t5^m7I,i7&nl-aPQE.)#9i Ċc!,MUv=H JT3U|futm'b֩ ڪk: #yKHBLNG W@VX_r5 bי 2C̿26xIpNdΆ%pԐ!I\gN92EFQba{^=|6zz  $l92""b˖-ޢ>zڼK`!ި5zftËCn+,@#R8 [=Ua7>￨bĿ9mhLE^`׃Fz,x1]t} $EsesYS+j+BL)NۚFo=|pX||3/JSOӠ9A<L7i+(?=t{sK}~#tSF]AƳ:F9{l$''a"E8NqP:7.|*-d7.[a "-6,>LW69Z1y|7#G>'wػj[ B'\GGӓOoo-.aAj,k\\kCLeͼ8N|u^?~+ 3ֆ[yys(A9u$&MŮGx;\Q[qƉ#6xٙg|̤1Ѡ{a.,Bsϯ<쪼ƤA".t(hƑc+&!1_:,e6cA>8tυƯW"7d1Pg&m\a.6M("@x?|JBX\[szz;wp8~}/[ 6P i-b2ܭ[ɍj9 9R- :3/ 4'\99n(ΐ%`}s扻'B"Zϗd_ŅW/gŗ,H I_Y_y닭s"_| d0DIc’@xIV\CdYX 3^Ia/Ͽ?`=N@XVK~KwqҚҦFzjN^cowSIMC[t)^zq5'1(/ :k 8~DEE6^VUUo.S~ž+Vnt&9WFz [@x~uHft*=hC _WhklnyX>|TUZKZ9cQa$%qzgb\`\痞O>|(oB3_F@4W_'(WC(.T̙3ܹC"_+B4HrB]+x[LZlR%6aKJUߟҔRT5FZy%d$cŰV wgfk_yϿ;v]d-dk XnZkgqw2n֩Y,ff|Û]yӾ_WoZ2'i97zX"'lM>f_v "+P;tu:,!KfZ7r[-b'Kz2IM /3$ss m T~/mqA_81q#oBt& ~lCΞq|VVq~!^_s/{?]īc.(J)' hw*{Qe/|>|PDXrg$Duujf"b=oPP… !B(nlMa͒% ޒTdړsetdhzJԨC/ 5ec ED7s {O础Z[n5|pcwjj5mk?{qEc7cJ]/?:(K/.AB"²e֣! ̪oj/QQ߁9g/ F?>wy3&MX$%'b$_JF %}f]P_i/?SRRқ7o B5i@(xNZ]Z<k~3ο)n&$[ NjL7Qsޟm SW-be0*l`xUvb#{V]a(}NIJ>}Ҋ[Ҷ@UdVuދִ#wpQem4P@.]u]u]\cnQEBDE:;jk:3 wa΍s>'j瀝,&@<1Yxmc/L=Cȿ:SN3V<]Z|RSxg͝qtfci#T [Ǐ Ĭ،kC(DL^sMQՉ?z3\!'%ORUqoc|TMz:⩌3QekKM_LJ@X܋so^]]SO2;hdZy y e>?xB@+GF:4AVG΍=sF훑rc mуt|\|fKѿh|VCIR7QP_-,r˗/777C|;b  UQYY 3R4)Ƈ9grq7~9ů՜lڈ+wK~YM%KKnПWŗ/)6+aD sjk *[F,g3.~u֬f<^{NCܛN9p郥A:ub iR Ru Yok*ow ӆL{]́aTl_<)ћ!_4ƙ)g$%\]o~Im~-Z@-X!ƒPN9{l`t;BF]{um\mɜ'OM$1E1%%8NLAZWH?~}NV+'YmVl̳GJF-5e{WvdD[X[s*GROAkIUD'CDŽGK(Kr7O7?}JAKaœsωaWEZ#W_9@AbXAAVcsq|5h xo7tyKult6l o*o+]ɺJԱ]2nEACbUVKaɯ+ӐP_Ǘ-99;v`@ԕzA(C\Q|EjenC!אkc9TT$U%q8--,{^SVoz;FӍsN˺qCgviWvdVT`0(eOzDT8X VĤ֢etdv-*bް1[k~}nܶoQн,/>tvqQE ^yb>uYϲ[o/+Zzߜ TT7lyW#Ϡ1&LZ`V䟘 1hHwi`fjkMa>D۰|5k]!T SN!`DxNGSPD 0LnbX %oA @Aj-lEHkI=,+*)"ݎ{9nNOb{E{KAKϸE]حtexeٓ2͡rr ) ="8z*/gymG: Bjkc/jaX,v䆑^wXpuE,l6抛сыn,!SO?Ybuj##s.7/Z,T]UJA* ,ĸDw|z3o W6t6NO>ma:~xFWY8߄߮7mTRRrMr :4rHEUE`Ҙ)f1cŰy,:&Kڒ3ydy j/+l*L=툛AHduSu9.<ٛ奔 3;:}bzD6}koξO%`$"Qk![ |)Fg>pߠ}*F*[3 aW_tEy*M*ewp) l- f@(nEX,u4 XI)~~~;v`0nVQ8e6Pz>%אU-[wm$Fm:;Of=d ^SUt(H&΢mz%k%f55h17z;=l|NO#RLQ-'l1Ȍ aRZRî `=d{C{ؑGbq|W7%oks|[Xpz8bcaT$J Ȉ#d"y틵JzJoGG#~$K.14?sύb+ւl-~HO'?'F)*JB(oH466^dݻ!P)RY'R|;^;pa5aR]ɠ!<{!7hCʼnDޗɊunVֆ`dd~@6Z>L%K{2<:zbDYYޏ"mmu/&( j_cܛ+nB)^A"D^}{vp񩒄=.{*KI UvGʛֽZeQ7<<L|}ueW:i: S}V׮GVKB/Ͽ" ,d "5v9RW^A@J=EDENRDBO`}EE-[u+A{2/{G{{'Cȴcׯ\Z(- N?8qKږ%­DA:rZy+fK![Ks~X OlND tVXrٲe ^t¢ nĤ1_Hۓ6;B@>EmLX,iKAWaZr "54]:T03t6ܔIN]n˞Ԟ~=L&F@w$zk54 Sy/l݊+f%T]pAσuxi޽O>]|7 + 2o[4f4>y&*1!~4#rۙT&}8Ǡ,CSOCdžZb 'I[YZ:1y"^]ג8N;Nw얣/pײ:5^+TWF?>xsM%s͑FהOX:ŧ!5yѴ~o?P<~̑ ~[Wr$;Ns) * #&'!,mOm61Iyg?Ub{E/^km8Ѱ/de=˲kӽTU?s%H\-0{0v2'IQ[o-I*Yt6LEv찢LK+K 3N M +ؘc)wS.gan!)/i=Utf~D\Nf;!vͣ{};̪w;F׎O JP>hf1Xi>q}qnj\^Mŋ`Dʒm_W3$Ywהt>}ݴ**0'5 , ?Q0XC!|E!TV1tl(<93bMKO P`nGs;Od3,:Ia66Ix!% %&8nIJ-8=_ϸof=˺0o҆WY Vg+7U4ѦN<Rb/r#fE ;'@xgɪɚ 1S~f'Oy+F ޱcD"nG@(*~]<ϩ{f ф9sv;0hyj}:IIM1Gʟs/ vu!54b@ag[^ Sɉ"ӻĪ ?|`׷rؕt+ Wv7uSyjy}Qa'52gddBlkQ3Vq89.|}v4U4]^xxyeVhM4Plٞ ~bR}0d| b:qC/^|%h(i(+lb%Z_}A= PW[\FCp#1iOiZj:Lu_ gn߾=22[ۓMYy]|?2ٍ:#ulBpB[ cg '(Oo?r LU`##p&*z3 .J&%Z$d1:f 5×XXKSfQY L;>xPowlXÛQ?wNs /Դx[[XV`2_z1-K)]~@]nݎb2<%"zs^̘9][ݏ=yd._=U,[lʔ)~~~<,b3B?l6;a}G22n]ħ+=?JŠb/ٍdFNa2x{n c =wдeҘ֌-M-p-:oAE>LB]v,&+Jg",7L YNNS1TѳuΏIi: S~.Uk## eст&gϐ&q( }k IAt:C#ySytJJR-OngoǢ}ݱOm [222=*//;w. ŊwqP1 V¯ "_%qcbug6:<3_P+?AvGh_]n9 m-"9_*0"Bc6D:)1=1߄c޽{Ç7ofQGyۿ4=Ng`<@M:^::d$$f9eqa1j6lur$D?9%"B bt{qٿԩS<ϺOTFҖ8DDu]v'v~CZZi% :/mRB݌gOֽ͚__Tf&T!u a>[#Oyjyd^Ժ3,܉pwfEd1X] ]t:/x Mɛtt!X^S:s]t{1b>Sr=~EZEؾ> x1u#vr*Lbee|/ FUq@î]*V'΄O9p7o1cƓ'OÜXoU_и dY.l6+p9 zZi;R;gCk6kmmaojGcZ`5B{Y}B,/PPKTd`ETU=oy E548Lu΀kiĘ 1>'VIo"sl{Ej"I `t0kԏbx8QVF~CĈ [1lhK LnةTNi &ibHKԱ ] IK(H)Jqtjoh dk0JJgͽ!ڮ8 QPאJcQkrq%#z ZIa**gTo [@뱜NJR\z~5v5jPbL3QT\%7Q?%GԬ(Ȩ{O5jDaO%$>-\ݜ"o׆#] lv*;Fs^=d卥"Ťfv F(tS8G]`s^()ͽѷ*II)) Yxlj'Ə6h hSQ@n# ݗI&[ZIU$r5\C&U-fZdw+WTҔҒBki-iBHNFO&}:3˘*+%jp}ROilj+nk-nE z@eR_o$P]ZWEFnNǏSnohEr^q0"?*kުƪ:HE % %hTބL0Wˊ((h++mnQ3Q[pmj(nͯm*kj,kD zRBji}SgNCK+K+h)(+)+d39) >|tݘ &UĶ6n gil 7Tn֗&"!pron&*)ߒG-"͒@5tI ;UӲokcgs}4G[_[!6j$M M4<66rH")]r2TeT T Y[[yeUexQ2#4BrFMjY5YdU#UeCZL=o&v#QFԢۛXIlj@sJ3ѥ99hфH)HI)Jɩ)(}=UD9R}?1mڴpgggh.cϪx/^Jy ]HEgs[ [[ ZZ [7ŠHIPɬWR\bzZ jn18:+rid'^hݱbX=UU%%Q龞 Ay]SX -(hMQYQYCYp2t%T$8ճ(8qZs'`qjf*giRm%m[ Z()EE]]]LVLpcF[D[]Dr3y⚀4_ͻ#q ff*++3* 9E2Dq\+%}%YUYN:DIyIN=- ;aNqBmrV?aXAl,d}N & :::6:Mͤ:^\VPRUUYExGi})E)nZPQ9k%in9Ezޗ5ȣD&5q^4U45755r_ײҶֶ6t1Z]P!VKseskm+""&-#)ZBV2ֿ/Q𹥳8eWF{c1YeК[ uNi.n_P)fq{_g򐘔dTeJJw<8'?'b&$qSP3qVh(wl'r{(ꪨs 6B붺NWYm5CCgC4B52}.Q++**S4rFzJd%_rQQ鬶BM& -n1ZZ ܮyc1 ݇}'Oxxx@ }Ӈ Xr.nYObv0kck o55qv27HB88E!nHm WI1HCsx/:;>( duej B,,Њ duMͫ9g0@w.j}U]jZZj$")If쎶MKM!3l(ᖮ)._X1bb3n]oK|YIgjw YyJ61wQIQafV>VcD:Dt3 ]Ji{Huy/83֩/`1ZVZFF 5-43#7˒аVXZ[^ߎ:޿gM% %={-`lm!43ZZvKJ|c/Fͫձq犆waNBw>:d:n7n=/p=QA[v0yƥiӫ8OXF.F;($l!MڲeΝ;wڵi&h/L_1b ]K)afQޥzq%qɆhaJnʚ5EWn6QegbRM-[*S(PYccI4a<|î;Lk#D^HDR#E#74v3~uhc5Vzh^ BKfVs&.#ueX%%!Y!YiXVQlcWcIyI-o ^rfRkl72mm=Z^S=ߢ8X^=pn&E",FXxyJԉG_P)..=tt{`fF:JhES\/.뱗/6yVۆEkfsEMjknQ)(-u}t4}2;e[ ZiSBGNQG"e|w杨]M<&lռϭY[,b۟n+%=%5ŤzhOaX2/)g3ydBWmN<w3-4tPU#U^::xTxqiqM>C _0MHrHKaf"^a١/iဉ9|М_2lz4bڣ}oGmt]w%2g^? Cr| wsr̆M=8UVrۢEG?bk6 zj`iRiؤI42y/ޚ'ЧRG̅Ñ9V˂7c>$lddd;V\\lLscώuq/F [կ6'бYo-̃W up07O?N'O9c8Lo61vUluTov[ۧ [&Z嵫#V{wuռ4Rez娍FC' x=8ƙD$'QՄ?qt^ /s˾F[]&toܹy/VD㇭#@`zLBN:oܹA|5iPWwq/m [,&+cF9c9#nõu99~m|r]Z'IYHUU O)uֈJ҈#4Cͧ [ #6Z%`7݈;n8M>@#i.νe/4U4|0t}pμ`ӡo-IJl{p=AY_sW پ[]FxTeVEL !7Q‰vϗ̐~L~ O[̨ Hi,Upo�0ᢛz}'{KeTWs>q㴃5aB +4tO$lu…˗;99ݼySKK 3kr>|mY%lEΌlLothBWJ,}b]5T@v옕1tbwLI(WM5Xw5A?r|񪌪vLG%pFzJR@}4\VUvɽ%&"}XyjIpxʐDzQhu30y@IUAZ-"^|%)?qD)>t nf-rqŬgYsqwDF]wwҡӏLjS]}z:| S}zi4+:T4$lc ]xx84a'RIZ{TU3;&ۮlck05{Sϧ 9rb8ns8dk!Ң,.] )C^~ek!56&lT6P>0@uv*zz(}<[ Aq؜YFUf7tlD qL!~W!DY|,)&;Z11w9Qޏ t橉׽^i7d@hF#|=VIbǭF[-\BQYVJZr%=yl4 _ha&.7Ԭ-ot:vxyu<=bΙ׋_;0P8'VZ|<2J4iikQkTv92moSS)߷uS:%snIBɪUF}IxBBF̔3L:OG!VO?i:t}xLbr|qr3*|S~jͩ}JB{ mk 1P^s쌳+Enꠉ'Z4"2cǥ*+̪+xit ̚k:;.ιȧCdf;c8Qx 7<Xq ' ©g(`oߊ۟8qO-K8%q~=D|F=Ux0iSwzy/܏ cWcE6=0 B.Ag :6:A$93UeT=gXgRZtkdk}JLJlem~ƿ:dm1q6}bfCAtqtdQwvh@~T:o̤3Qǃ,)ퟲeE y:;O;8 3p@@[IhB؞~Ynիl[8!õpJ4Y,:?h{j{\HۓV{.VPWq'3Qņ)[RYײB1Hy2ho8Lup]KƄB|gZ 3!~+Sn=LNa$ =@m#SZ( 7q_>|++ ¦7ւoG f[JIZI;E\B/~~/zkZ Wd)3UU#:#tt}t|O%3(NJ,yc)@{}cmyRǣ? ̾)xC0YA+*<;rH^@Q[q틵gy[ >l= QS/Dt*=dWUUU!\cⰑ"yϨcQ5j^[3!I{')h)P6^s%Dze˂T[JJȂ9VyHy xUu |".]JKsīk+i e]4v i"~ru uz{F#m{<1{YcwB~aH9.JJ?*"cm^DX! F6S"&ǫ^Qh?>ZNxN{s&T^/>dgv_E7;H7DFn:+j;5/*M体z}V\Z1i*o|YR6ܜnP7D_=^Vk k2ؤm9ʿӫH # Z8Xx|ʝ6]oIdL\Sa^z78QFYc26x}0Z_tU.ͻ<ٽ .6q/m=z[JsȴKg<X*!#4)zvn=ZNdeeU UnG=_6߭=E.OӔVj5-/A.zs6jYr`h\aL!zޡǍuc^z Ty?)11z]eDmVGU7>qb8b 3&M_-J~/kYyfZsʅNׇ7Aߝy S7@TVCA܏drʨ8~ʛ,ROc<:?@3a=d/P=kuUCo_kkN[_GuV , !;)" ~'\<,6F,%8"勍w6١DUx!^ ʴJ8]+.7 Nu-yY҉c+ E^?4|և v?\C<8N& +ՠ(Rfv4uuýɧQ`빲GH,u jd )4͋;D+_++?iv@4|db|!_8t+jqr s[ hbVVȵKqi>Q~SXM*k(/y"EWsϡ8:6鑩:ăN?_3*fלk9VYMV&9㟒3T\⪌ ZX1b)&F!\,3+cVz9ǚ>&&ӛ6m|bŊ~ kk]FOM"ݩS *WWY/=NmVET:ƼBFsۊښZ[-Xe-r2f*ӐuuV_47.Y{3fOcSA{USա7L]Iߚ(aͭ& bZY[Y,UKգ!kVe@Bs(2d4jjb+k)?:tθƏoi"նZ㠱5=(UvʹƟ(J*EV/jfKYY f 3+,koӌio mumy9KKEa҉$Iv*2b26HU+I]M^/'2aݔ(K$ fuC%72fDsJ$Y,4)WƥCJB!̘q9#àz>q\](* ]gX(Sxxa4kiq۽N@锏h@qLJW72WlDc* LMƽ9.;,OWX9iBe/DV h,chjvhXYgg56z/ַvPPRU%H׵c!w؞l{X{}{tE:9!UgISuz.6i+QuFA΀[FO޶ͽ?UëѲ,}N+-!KՔH:,{w?qGnGRRQŠƒ)drB>յFVY˗,ZhժU/Z:ZrFy_HU.3wV܉ ,*=@C@1F]3 ̄UA̗־A&zSiD\t μlsdc3btTbƋD%==|#jVTXŕ 4;3ơ vd<ùY^3/"SqWke/g`G$bI-6[|yɷOd$L6K۔Rv$JɮÿX(;M=L  gAF%ଃy%vCEeEd"" QrJD;E]KR|vTgU#wE#5i$nwvWQ\.]G/q]gT0.;HɅ4.{99ge!㹧~Ck7[eeV v"Uq"1ꘀ+-ݨBW1q5A!B^^' spA׽B6d\ΨJ"eueA(zНILo"78֫h@'?e^s^9Oz@Hc)F_sşB$KDST{$N').3eXr-]d&7aqk~бzzu>;/<u{`E',W1-{]>!x!S1VYb k%mLRTf;(=/?0bCBKS߬xso~;M0[7Yhqml˕ LMQt r:FQVSF3tjjxF4^ku+jS&Q~BcsB(Q\CEjRͽY! PVKw'UcW:jOWY4/G1 5͟wo %鞓ok.k%B=|rZ9&f~}?ƛKȾʾ'@1uTB݅Sg+.GT[ʢ^I00${չUOO{8qڵkvvv / M 3 }!#].`}!iLĮ*6ʧ>>fy aaIU--gl:0e㩳cl%b8峔 h6HJXw/PNt\MzV1c8S`cO ((:QE5ٌ f}V~~ j$ͿƈH"Ru:8"EA)$i4tt̜\|vYe5=]l^JҌ&&؏մ`ߢ_7r2¾t4/ /}v3hc5tuJH*rN]W]M2nPW%"Is lN$!/>u/ ?* UԾ(}{}Yf3)5wj <>^6,-p,ej'Qb/+ʂ<[q(>cuČ]iEF{SǪ1" XyUV[O1VGV\Ѱwhn(BOSqӑn?=ѵPkGhбԑS~vc#)2'u2hl.;!jO2w/9is7=?.k{`1"W"bңʣ+ X v3[߶[O%% .NPs᥽#cWP|pHal!=繓N9tdޑ/RPb_q8uk SUFF}NQ[eE7Қd_kbpѰ,ۢs,\' mm,o-&^n;˓ڞ)X H$"m #+n+€D֞ijYaY,_/u0ǥ5K_.IWɽ/L8k{pW L"^B>;a)WNq|1Ͼ >4#͘Vz~=Ao޼ବƻe'e/HJ$%yG$]/N μ1SP%nM\7ݾ{}zjtSNQݝ%]ЯZA\3H W*$::dUrGeG֐M֘>5L!=_o+<#⊪e݂}zytiX$G=<55Rf7 NTèdHGVB5" P[~x5HV";Mw>]u2%,C COO;\~RnMu熣f|9y{9fd%U\I^ٗiQiZ[v{g1˙}]빺MxXݢn|iyr\넽频^j<1xu/ﴉO|oMض1f#:~ۏ~q_#.<\K$lhdvbŠ㟬uubo lmdHptu4zYvD8qk1cdAoײHTй}v%}=[Po`P\\jj_)ha꓾lϝ1z^ +}Ql!/ |ZYw/Uð6ka@[8?|2תɪs=YR( Yqp‹^z}! 9 ,8@τsګNRWrl:/sŢ'9Hdy Yz"@Utۉ].K7_tw7зiN;—"qx+X;LV³4'q?8ўQxkϬEƉ!:DvpڧjO_[XQeEwsau2:YjmSEE贶bf &(fė?6__r=⎲Sk,88 fNj_ƒ)S7Sз2\IB^@iHlcw> At&)!:;ʒ˖Zcy,q%,V^ߞbv%4 5Y f=~l*nz-">U 0o{ [ج4X{"TVxIe^{lvl?hɤܨ㫎R*Q <KNljS$]?\oꖫ* 2m- ( ),_1Sʏy=@О`hN?.!GP#uZ걨TM*:GcK1o08H۷oMh ɞh?*": {)+Kɛf@FB:t +.W]j̆Djᒚ[52 ODE74q14E5/R ڸM\]o]V)+燜.BК SUE'Z-bW++ΗijZ.,=[ژh2$cwF_-6oi-PV|XO<:BD5k-GS7WGmkgNq3oDg45S5YD61b\r$co-#w(tT]*:GgD )XVthfw䫊 l(i*u>IFYD%]r꩗(  5Boun55{-}kkWeTJ۟8vb͉{f_)ؖt")bwDO1.K~CG|!_hfB"DZPR\'_w5}-:C(ޟ.GIdtyim(hx}nZUè`H^DҐDç֝hxm0q5 F3y 鑻#Lv GZWMGMIEzuɤ+6mH Jx,{V>V6OC<66脇EjޮyŨ?蠩Rtmm_u.ᑦ1?wңA(4jxhLgiwvٶ6Ԛ8Kq4(56i; E?ߐmcQL}{}׸;Wyۯ|q2 nC p9ri]  =ad{,@6l Ce ZSY>MO%(? uucrQK f/K yƒ"Yul9 $B+"AQ y7 ]jȗmjM]u/U=&-$ (?4{ڴiyH&r$ F.  J :bx2~Kҥ3]VGe@:36&ʛ58w&}TGkiXk3"BI{q;0́FVeֈ"VKR[8uUcվWHq{ǹ~XIP0&9't5'V+`0w8x__Hlhy{Mx mN'xDpIjP{:ǒENc+}tgy+1b>MlL- ZZt,uZ!HN6a28eqם_]Cj"441Quu~mաo&!NaU-աD"rh)eP' ,bD&XE4aްаQsϙm^şVSeڗVUY\}j*Hp2@tGSSs޽%%%s.\04mUEõLfݚgFDUnK.U@ .2QhZus~:38$"ICyCw7L>>#H;uDT7G*M*=Tȧ!rRk!go}h0UhjQUީ]UQ_ǽ9N~j-?K"vGby\H"8Lqз5 Uj=zǗH$b#v%!VcQo̺L鷅\!B$]&ܩ,ṇtՖY* 5+XLQYs{"X ڔs+ ^Z 6jd W1':6̑utRk%E!3\ zȑ#K,򊈈-(S]?s}x.GwMm^w%gp9!N fP^IeHR?!V~HAմsDpb`">eJ &/ g .8ѹSc%G6n_ߊEb7cW^uh!iN -H"{]mōdT>iO>+Քם[e7kOQ\T wtۉ̭( } **}W!_ypmՙ}MabraYzˢ_|WNd.iFi-ò6 ۚ?xϧf'9g>o 1oV:p ޸qzOI~F=)oLr~ sQRYfS_} YG4<3%Hfޜi0@RT2f{ z| 2ؙ]͎)gߞb0\    s]C_B=  D7]ҨVVrRKEKve e#'RJ9Np۹4c]AL-},߻3y EYaYG[SEs[[wyV䇙 ߪK^ɪ1r6ӀEcKE-ZrppTsC!n]ި˜B9JTW7ިg' j:;؈ 6mآ3)7*8t^}ruɽI^.;BRXDlԾ(F9`{k}qomCWͪEf V><r菭|IIO"WK|]>(z/FEEر#88xPDh"<G4 M|h@A6![Hx]op$@]4p?M.9]b'e! DiWԍɍ7ܤQ_f:P%A`Og>8{=ww^˫Bї>ҟ*R\$uOBդvbr۹L!<"1>0vؕGW{Ϝk9_4&1J"\y-bWDڀI߇+_)K.ZYX X;FB0doo2kAf|1CUKuPS{xa<^!(-4 5?pzrA:x(?6yzt"1z Ʒ7f?~Ճ\}5@u$8Bp[Arrmۢw4zի{Tm@[|6&6Y;ks∸fPV?o6c1s7`1 y%65 wG>I2bws(~.j)obe>|w/99k ӤSϦ.ػI9Q¶98.=tx#SʨZ NxɉȉYXf;6h}L}.5̻ݍ5i oV\ڷM`\B_ymZ}(a4udޑe,^үDgןM;K~"z."h7 ǯl{PW76;M}@ P9011YbԩSBCCܹciiiaab{kC1VTssyޒݡRVihLSqSІOГA}RRQl\ꖫy7[QZ~hkٯ}ڢɻVl(j>M7_ͮ Np,|p֪w/w;g6F1::POJ]~wO_8a:55D Ȱ5Ho~'&MzQ=+cG)*)|Cɰ%C=a7Y|&v.Hmw$O9ٝG}Ὢ]:V{mrxׁH~I("(ǜ̯3UUN̛gB44:"} jZg -2plaxE9sڋ ':`1y3LtIb ~/(\ Ւ!` 2dQP|֣HĒ3%g=p2h{.ړw w֍E?y%~} ,Y5|Gx҉$S7E/9}k)o r:p9 _b8寔]f;34ѡnq靌Nwys\<͠j^pYYaY99V7y/4 ׶_yS7N)/\&?v:xQnxnB_w">Dg;Ms9}+K.CQ:72WV e5W$}-;蒻%ƮƳ@  ɓ'`{_BDe@Q|fM* b&SM^N9lIRN-GG=dծY)_*;6,!*qEffWVyV1RJl1*[>4<\PrӋm~2u(}S^2ЌivY32o..l[XL-3L x;@UKuG_na#=UEآ+YWjC:icRN$J.K*SQz5@[҈+ > Jͷ];vXEKm$-_!TT,-,Y57u72z[˭ΨF)O-G%"&r`@`1/JĒ_#D׷++{vyo=D2jVeKiNq-Fwa5o|w }O h<&p]BQ'xɮAy%I\VIv#'DKjnTn̦&5]5&d{ a[r!))iǎ7n 6mտb/[8yϏ|> "ؒcWWETު5*d==}}]o]e-Q1"hАx" ffiXi.-I0YƫKe8|ls |w|fexeeXecr#BB`c"/!B֕/,ةm=aI'oKk[qsl`=-z^l7AbJqoU[[RϤ~]nҘc;9Lu9%ؐ'##"c-؆8)T~EKY :bfjl$ݜu_V Eb ꐗ?G^hfbc6+_QTpt4wD%_LqSNTW8ecQ54S[(⋬bcG즽=lkؽ<IO\7ٮhƽX+SJX6W"֪ݸ]*EJ:4v5dod|i$7~'E"ѠqXaG?-`IIIٱcGTTOhh3qg "NEl_dI/luGn}]쩣Q5QvvF{-g-u+uҋ/4%bWLF&@vohhhr KPYUOEuT%T1V1hd0 6F$%BIk^+zxmls&!&dy%4`K$tidޥ^qYܼyYaY&GMW&F>'xx=IĒƢҒ%w[Zd{k9ӴVFD.t ͭݔIΰ겤2d2nJ:8:pvi.Ӝ6NufuUzUmNm]n]}~#@a{-3-MCaq8cjښ˚KѾQɐ$[1`躻獁ߊ|YWe٪ڪh%* | K3V#<8(F6{ww熦è†H9Ug!oYWܻNa]^zGNne_ډzpʪU  1nJ3y x[-sΈooYf3X cILjDluih*m%REHP3SӴ԰@{YP!ӑ%zYۉ*aI2D }ۭb#=45Fcáا).>1Q)")\ݴܴ[(C؉f2|&ADCIq Nȿ`ځn|EjEuIB @Rз7q51q3ѷױѶzGR(g44df BE[@[J*J/L DUUJKLhFNR6ݔXAVV"KS(v4J%ZfZV㭐mmp5yoKY 'pBE@nBӤ{QU[UMGMi O,wv[ҍf7ژ5̶G6n;;SYCYZmzzh1P cbѝCwsKiȔv)O)GQ*J,wd"1(NJ6bT2 l9(H64hi ǚ}#$Xbp?>e%s&(mwb&bdc6e!eZEADe(dTgUKE`MC,&fVX.r_b/O_(PTUJ=**!KÂXCEh)DcZ[Pl'(͡t+^HRR  l iii;w  3g^-DUWsن|Tz IRRT1U4r*G(i*P(㍦DD(龉bK h1'3jYJ]FS\VSNSY[z%ص[ AXUDUYG ) D!ҽ"Q"b _u٥k汫܆ ]e8ψl!~yМ&6f2k]+k(kkK(R1 UJDBE!^X5fV3;:ISEBQz& ٞ<["K \N=S#h{$j{"=Y].D饩DQTi.#i.U#!zAgIuwp8eX-<~+_q@:"`. ua:+);`Q}gm5GM$I3ZʥYd,L BI((PU *3D3aQ-@ fdV׷wv"K<Y[&ϒTdvU-UlO3ikikӤvW+yRY= H cYh-COO\$tr[}@.ӯ`{MjfM ]G2( (*2*idaq۸BIӲ<)dPLe% t2K@~t~ְr׽g7Gٹ-FRj [$UhO@TЦBWu=udd]+]@EvH:t&Y.>fh;fѿ iR;1|1#y@$Sq E*L݅ɼ^@qbBcȯ- -` 33s׮]W\quuݶmۂ i-Hw$K aCl!n~ꖫ[1APRij5WfDț] ?xkBv=i9i_j˅ vڵd-[D X;Yoܿ ߘM!aH"}q{~wº `\qb鶀+ĩj@V-3?bWDIB$1&q?55ؼ}mE/S1Mxe#ڵܹs[lYde[,(c[2zD^bJ"b\rМPmsm0)\@IDy[wK$6 D,ɸqigmeof% % $<@g],J"Fw>{W_}tR@fG^X||c"YX`Kܣa[ˆs-x]sk3zOxw2E8?D3* ܧonmfFVɤ{G56y Y>l` 6@5(..޽{_eeeW_-[Lr 2|=ILZO+l!**损ZV=DVaLO,!+Auo¨dM#A_5]F̂; jV5ʸyelqڞ8qb۶m{Yv]+V/z.LM؊cf^f6abϧ_{03sN$9|iG7>r ̈́|*);y5S@sƩ XRx0LjtG0aݕJ`x [#{wЋFsڌ%_"fǓə,U%Jyrc'-Iʽ.WLrXJ3 -7S__<.Kl ͽ-HƎohuRfգuc;wRG~laf}OΉ^vŷ- cfs%:%~nh|Map{e%JD{OOڌM9ϴE` 2RccAAAs5w_0۞]7k~P(W^5~QoMJɄla^(ުUa ?p23Sp.zŢܘ n*`I|x[qɶ1v=.?n%-IRUG` 2X[[ _k?KιO`Mߴ-Mǚ\^ \-$w#D4%_yu&pzOXdh1DeE9p&zMKKޖi굙We]?Wȁ{!p[nTGnkY|vkW(s`_ܖ6s>Z +Ǟ']/5S - EOx怡Ր4iTLqjWˇzd} "#BvLeYl5{kJwVwNlIZ$ӊP("7E` 2ܞ;ξwnMaaف-Y'd{yU]}>00՞癏ѷv}+n^ l}W>]XLaGE>Es ߶8,% V/>A͒%_4rZItlGY+-].cmFU'w83 -wF{'_~ _aj6?íJr|m LȆGZO~#Qosg>SP n7,ąT2 U|>73؂1^,:́+}|}jނ.H_~qzzn=*Z>muڼ-n#{9]Ɗ*VgU3uEꜵs2fŲ F` 2ޅXo<ƛOPѐ0'amr>LR^4%3vaheh UZyq~Sń`<[v腢P9r~vaֆ,ətErNHOܫ^+f/؏ɹ4⤷⃊+w77+r%IޞLl@` 2+f7.?ɹ]W i_.U:,DDNO_27ȗ)l\X-wNzѭG{crcݐs{0 )!q!o3 ^腢}o뾵n˃[ la0uOi] 5vGޚoxל+doސ|\U*wUVj<(ΎN_:=uU*H‰elK l9o+>8#1BCr6nʝ:memx@GE>Y9/s~DR\}O{ ]}՛ـ-|Zvˇ*ޯPR=-rZ'y\􃽃}٩R==jwUŇg "&'&uE8M] 2E8-r{r{B[{X&o̫2ɚ~Ek94n8ҡ/n+mϽ.7{cv o?o }bY70 OD{eW~w8%ߒ/iM"^QuɶK4~W{ōQP0!-RáïUlۜyUE&MgugRHa>E/Η2ΜsgS]JC!M&yYJXpzx.C`ME`jV|PQVh^^+S3ȼ*3:;74vMq;'{c[eX𖅟*lam]UG^;r#==;s~|&ːarqjt՝s#IzgzzV|TSQuF iT%#p[noJ[uwn/=DٻenS@D@9W>2:o[;MDK];\X|/Weܝ.q``[G-V27wC^漄&gRXtGiَu+6?6s]s$%ݪn88)iIRĄ Ԣ?]LȬB` e,ybћMaa9rDKYRj+o+Y./h'0bb\9GBh.n'~rBe1(ND$h¥l\ۛ>6{á]UU{?hP{ ⓗ%KII^aw4k7f_MWMبO֏z016/Ep0kY,}#|m 2{",@RLY!;{c_b+JZ7)SפN/f):n9U[XP`ً'N>8|l\ۛ3tTuT節[mm#IEy{*EdFdq0?E/ @` a5xTLk[@@PLP5Yea~.RRK!*zC+eYJ5lZe[^Fq"-%J`qôA` 2ܞ[+WSvۤTED',jh^Ny:k:o807P*bc *~GCBWt :&d#q8 'aA|*RNkCVLN sVVhŇRU>>˒SWJ+Y:[oВD?1 NR =Q{L[.C`]` URںuCVowl~WsĮY)npAܘذ0*7`F?ww8 l ͽ'9!Zَ2c1020 ٙ25ҘfY]Ufoe柲"%meũ|Wl(j/ iI'c )uD.n^.l\sxvV\l؝-EdDo!CpC&kjhxj.%Zr* "@oe2.pOG[i[[Y[kiŸG̖BM O OHEs/ǾX pW̉[gvCcFꊯ_43 +wU(+}T| RHʌI'p+W#&S|p'&.JLZ$&߇k铲Y4XծRẺɉΑf![!l]@_Ks V"EI᭹RxK^/|wbWKMTOϰ԰p-08Ir?wH|ȭ5uE*s⾎7]q7e)Y^~EZ.2̘s圴i S4A]u]ꥐցa:6/%f eD -SI>Ύɕ7ɉ'B*Ol\#5qbot(G#2""3"EWB @,C]c:d]NQקE/ŹR8(:J]u]|ⷊݾl˯\`aPLgv4o%yq/VU i_^\ iY;"muZ9W!;A˷ɄzcQRDeF/OX ZLNl '9yNIkOC)&G% ԁٌel=[C= =c .WXZXDzDĜyDqGsmꕓ[՝U@պD.IOK}[ģ.`PܽYM?ٴU*5Tϓ_~rc{V|QVnM?Lakm:=}Mz괐z{545b)z9%ZܼYM*Ef5KDG57J.& D -G`kmemrU%% ʽ>YR_ mΪN)%ZM+1KIY-414$6D&yoxxGXJM)*~ht3TfooiO񇙙M5j*?M lf[hBTIk4GH"뻥h9,ih:<5brqΔBZ܃d!p[n'e4,-8ޒWBm] U(5ɹәꪓET [!q!!!8>Tlp/@V_j:ڴE:0'nz}n+-r7bN>qVCJVsq2-eEJ`S#--aK%f/6/6._ i\`fI69%2ş|C|#f2"#25 ճC` 2il4wVuvTu+!58 rrK\Q|HZV}X^ rYc@9,ŹD ț3vM^;i?6>H촗WS]Rjel~lԕ)So1i]5]MǚDk>tSŊT͒ rN;Ƀڮt;Y 3R.C`ؚ:iĮ.yDwמ.Q'  <9 %{zzcQT+vt$zޚYnzw#{eﾟpl?X/?6u|&,OI]4iVSIfon>,ETtrBK44fc0^VQ16" ԄEG>,5ϛ]d -G`}wvɭS z{6G-𖳉-]j-o)Ma:@ kAAݙ ~믻jǴ+ݿMǰimol==ꫫnMxiI>2w|T#8&/K-eYJl~JbdAKkikKqKKI:'EgGĈ>:':jnԌ"zMkʃidJwel=[3mKZpt rΐ.Q, H,9U%&>jEgI,94etF"{=FKf&xrᅏL.C`ؚ%vG_KߪV?lq vhuZA ȯRIo5I}SظW)Z:dRxKܧ䘘Yllo-mͺ&kݷ֥NgZNW]׉OTT]c(JЧ#DjOGT-v۰jZ,Nc{hC{e{{y{{EPߐB̌LZ,ysY:!uao KVd Z-mem -%-՝#*<-\ZiuVwz(<[8IQYQ|Z*vK9%z%"T^H9%f),5le˗#Y"'Yb–⣪KIфVߤԛf[!l|\cɁ0R*6bLL=&`h1Rf[դ8Wd3%MQwnv|;{]νOsM]RO݃Z,;ˋ*>ŷ-^t"%]]WXW[(e,M&aaJ\7 FUQ^V&Y611L!vȌH@IaӰTR^tv,%\4KRo@}^ZN9-r{p Ʋ\NJfIq򊇁QcFzx^m#\Z\RaX/_ ]~޼q.69믻>]XKsϝҌSAl?cbO^nYQzS/\P0fk?P/U++PQs&&.NLZP(f(c+f}WM*hqU^3"#"*3J13c~f)U%#r6swltK4 mu&WoSGh{{bcݲ3g}kO (fٷztVO1R[i[áV& x?%'lirƳ2(\=5$>Y?ćn'x{jަޱVsPߐ|5*(*h|$klB*T#p[nf!ЩXG}A2UUdJxPװiXgo4' zƱFyj<괧 Nbo ]:ʑ_^JJ"=r#gϮ{)_clGo}nݔ;m]%nxoG7ǚ74i}KqmئQJ5%$DfFN`f4tuU];uZ 78zȑ,n< ru*{Pk-}v]&H3GM|v!k|Rl\#YfI!D{sy}yıE2oű`p*LP)B?ΤhxǏv;', ݐ5I57[z7 YGw |ǟΪN#G4<'>r6pcƎʎLj&H+ظ7uNvWJevfZ :ޡD]hBh΁_t~]f*E ΋}}H<Fǜ cOhQD` 2- aT1:L=O.?)\u]x?|3_QRqrƃ XG_;z}5YWeNQ &Чzjc{o go]jǛ B}w 7E]]5 -=(&(6OfK9-]M'M|{{{zz{DZ AH<irv8f+Պc9/ZL×Rk##"D/-ex20c=l\#\q:uK+RyZ2U!~RK B~{hːA.ʃa[KΖMfZUxr8jn=ZvI&J(1㪌̫2&{ %AJk=ʹ6gf|4sϓ_zr6n_J9$v۲ۗV{ˉzܛ:iR6k4ihZMXqoS3kCBBbCD,z90}^fiَSK:Kd NMcI}X dal\#Lq2 9CTezLc?U*/ 3%m zMF+j/m΋;3hOӕ r9eeA*O:-;Dَik3RWFgGc߿7_s˝I_w_3jxx?{CoΨso_Zv]oVLN4_O|؍]ƾ>z{ -y ռrk|0KcC. ^8&1,qJVjuڀg$˙ǒY3\-r{aw !*gjl0n Xy&Gi5R zWQ<`>\rL~b,n9qXzR,p wWɭńg8)yYrE^zr+gׯ??gcw7jn8O8{|ŒƱZ5"3"ao4'Z EI}H`P|"\<7,P֩A - ,@מ=WP(el=[1̓R~kC!kNZﳃ\vq}91lv.܋= m\LvfL~AOr8%UTUV˒&͏ K sMpC+YPp+[?iĜmڌE6ZR~>ma2KK{S8>5~p%Mhpyb㶘o%>hr_΁VeBl\#lv}OJnX:ol gXP)4x?y{^(^~^C!;GȬoKj V~{qo84c?U節[G O&6?6n^h'֗^%JJňc$&7{X'v<ΏO8$6dxGO?.Q7uOIysF:S^T i.;i1ޝwbBZi бV=sK,A` 2-g6 :#uyZob oב)RvqOVUNut%Fc^΄B:?&@, w)..g5䈇dy𻩫RRYO{ݫftn~7|Omm8԰%o<`$VW8Xr`  _yu?^4ԪzZsRfQ޽F9b\T̈)* MxR՟_jɭS.ьf".EE#2d9g?/_SI/=} ].];:d"u/``Ϡ4&johd}I,9%gawHFw'n6~,I'`]LN婒*ƍ..ʫyf]Kƒn%)$kL"\%ι4l1Y,R  BvT*)9R+*_Kcװcw=~.Uhܟ^ '睇m-O՝7\y=WxbηNxykJ[ﲳ?qЕ"΢n> ֩A=OO>D B#܉,x*3.%ƾ~10:.~؃~,K'eK(_+\ps˜tI J+GfJy~Swkg~vuJn+vR(qqX7?NT}/smNDFn_v2BQt/R䴖;[Vk~|A_{ZSxztn5W=~xJ E-rrE*H[NGDׅ2uGPֺ'n٥;Js^S<΁ACanʝgRnW}+DeF{zٗ࢔LQs.&5)^R2)67$򮕚@5WvUzPԜkso]+~[~yᆭ?*rn,QRܲky`&.뚬7~Ɲy9S[X[tagu-m,]} JzKc1Yyyʯ[y߮R\_VݽrxRcby`cP(7=|6a2e^$.L|tVwn36*>ٞMF6bl%|.e~GU[]q\,Ǔ!;osS_ykGi<ڨK!!ZN^Qiy^\u0l[6n{/핿}?{ 3jmvG^;כKn-Je6B8 ComK5/fS^z_qV&#YL 5Sɻ>+/}ϟy|wrT*5{-_ok]aݽM^̛ S%t9ܻ޲w\`gu#j kwayvwoOO\xoʌr.C`iawǞyꫫܳ&$6dE Vxzz{}*Ob ۬fe"nnh3 Z U!V/OZ$ZDMy`l\#3@{[y[{y{WM .MVU4۰frxKi#)pm)'J[Țd 5l!.B` \-p["ELlh0 Sy<=<kؚu=EccIDp["El!.B` \-Px00e93`(FF7a$SDa:!.B` \-p["Elڱ Y*&D[a `"lLmZ'%<IENDB`lens-5.2.3/include/0000755000000000000000000000000007346545000012276 5ustar0000000000000000lens-5.2.3/include/lens-common.h0000644000000000000000000000070507346545000014700 0ustar0000000000000000#ifndef LENS_COMMON_H #define LENS_COMMON_H #if __GLASGOW_HASKELL__ >= 806 # define KVS(kvs) kvs #else # define KVS(kvs) #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_bytestring #define MIN_VERSION_bytestring(x,y,z) 1 #endif #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif #endif lens-5.2.3/lens-properties/0000755000000000000000000000000007346545000014006 5ustar0000000000000000lens-5.2.3/lens-properties/.hlint.yaml0000644000000000000000000000015507346545000016067 0ustar0000000000000000- arguments: [--cpp-ansi] - ignore: { name: Use camelCase } - fixity: "infixr 9 ..." - fixity: "infixl 1 &~" lens-5.2.3/lens-properties/CHANGELOG.markdown0000644000000000000000000000036207346545000017042 0ustar0000000000000000next [????.??.??] ----------------- * Drop support for GHC 7.10 and older. 4.11.1 ------ * Update version bounds. 4.0 --- * Initial release containing the properties: * `isIso` * `isLens` * `isPrism` * `isSetter` * `isTraversal` lens-5.2.3/lens-properties/LICENSE0000644000000000000000000000252107346545000015013 0ustar0000000000000000Copyright (c) 2012-2014, Edward Kmett Copyright (c) 2014, Oliver Charles All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. lens-5.2.3/lens-properties/Setup.hs0000644000000000000000000000005607346545000015443 0ustar0000000000000000import Distribution.Simple main = defaultMain lens-5.2.3/lens-properties/lens-properties.cabal0000644000000000000000000000242307346545000020126 0ustar0000000000000000name: lens-properties category: Data, Lenses version: 4.11.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward Kmett and Oliver Charles maintainer: Edward Kmett stability: provisional homepage: http://github.com/ekmett/lens/ bug-reports: http://github.com/ekmett/lens/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett, Copyright (C) 2014 Oliver Charles synopsis: QuickCheck properties for lens description: QuickCheck properties for lens. build-type: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.5 , GHC == 9.6.2 , GHC == 9.8.1 extra-source-files: .hlint.yaml CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/lens.git library build-depends: base >= 4.9 && < 5, lens >= 4 && < 6, QuickCheck >= 2.4 && < 2.15, transformers >= 0.2 && < 0.7 exposed-modules: Control.Lens.Properties hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 lens-5.2.3/lens-properties/src/Control/Lens/0000755000000000000000000000000007346545000017116 5ustar0000000000000000lens-5.2.3/lens-properties/src/Control/Lens/Properties.hs0000644000000000000000000001055607346545000021615 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -- | A collection of properties that can be tested with QuickCheck, to guarantee -- that you are working with valid 'Lens'es, 'Setter's, 'Traversal's, 'Iso's and -- 'Prism's. module Control.Lens.Properties ( isLens , isTraversal , isSetter , isIso , isPrism ) where import Control.Lens import Data.Functor.Compose import Test.QuickCheck -------------------------------------------------------------------------------- -- | A 'Setter' is only legal if the following 3 laws hold: -- -- 1. @set l y (set l x a) ≡ set l y a@ -- -- 2. @over l id ≡ id@ -- -- 3. @over l f . over l g ≡ over l (f . g)@ 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 -------------------------------------------------------------------------------- -- | A 'Traversal' is only legal if it is a valid 'Setter' (see 'isSetter' for -- what makes a 'Setter' valid), and the following laws hold: -- -- 1. @t pure ≡ pure@ -- -- 2. @fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)@ 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 return $ traverse_compose l (\x -> as++[x]++bs) (\x -> if t then Just x else Nothing) -------------------------------------------------------------------------------- -- | A 'Lens' is only legal if it is a valid 'Traversal' (see 'isTraversal' for -- what this means), and if the following laws hold: -- -- 1. @view l (set l b a) ≡ b@ -- -- 2. @set l (view l a) a ≡ a@ -- -- 3. @set l c (set l b a) ≡ set l c a@ 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 -------------------------------------------------------------------------------- -- 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 => AnIso' s a -> s -> Bool iso_hither l s = s ^.cloneIso l.from l == s iso_yon :: Eq a => 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 lens-5.2.3/lens.cabal0000644000000000000000000003462007346545000012605 0ustar0000000000000000name: lens category: Data, Lenses, Generics version: 5.2.3 license: BSD2 cabal-version: 1.18 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-2016 Edward A. Kmett build-type: Simple -- build-tools: cpphs tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.5 , GHC == 9.6.2 , GHC == 9.8.1 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 . . An introductory video on the style of code used in this library by Simon Peyton Jones is available from . . A video on how to use lenses and how they are constructed is available on . . Slides for that second talk can be obtained from . . More information on the care and feeding of lenses, including a brief tutorial and motivation for their types can be found on the . . A small game of @pong@ and other more complex examples that manage their state using lenses can be found in the . . /Lenses, Folds and Traversals/ . With some signatures simplified, the core of the hierarchy of lens-like constructions looks like: . . <> . . 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) . > -- quux :: 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: .gitignore .hlint.yaml .vim.custom cabal.project examples/LICENSE examples/lens-examples.cabal examples/*.hs examples/*.lhs examples/.hlint.yaml include/*.h lens-properties/.hlint.yaml lens-properties/CHANGELOG.markdown lens-properties/LICENSE lens-properties/Setup.hs lens-properties/lens-properties.cabal AUTHORS.markdown CHANGELOG.markdown README.markdown SUPPORT.markdown extra-doc-files: images/*.png source-repository head type: git location: https://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 -- Make the test suites dump their template-haskell splices. flag dump-splices default: False 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 flag test-templates default: True manual: True -- Assert that we are trustworthy when we can flag trustworthy default: True manual: True -- Attempt a parallel build with GHC 7.8 flag j default: False manual: True library build-depends: array >= 0.5.0.0 && < 0.6, assoc >= 1.0.2 && < 1.2, base >= 4.9 && < 5, base-orphans >= 0.5.2 && < 1, bifunctors >= 5.5.7 && < 6, bytestring >= 0.10.4.0 && < 0.13, call-stack >= 0.1 && < 0.5, comonad >= 5.0.7 && < 6, containers >= 0.5.5.1 && < 0.7, contravariant >= 1.4 && < 2, distributive >= 0.5.1 && < 1, exceptions >= 0.8.2.1 && < 1, filepath >= 1.2.0.0 && < 1.5, free >= 5.1.5 && < 6, ghc-prim, hashable >= 1.2.7.0 && < 1.5, indexed-traversable >= 0.1 && < 0.2, indexed-traversable-instances >= 0.1 && < 0.2, kan-extensions >= 5 && < 6, mtl >= 2.2.1 && < 2.4, parallel >= 3.2.1.0 && < 3.3, profunctors >= 5.5.2 && < 6, reflection >= 2.1 && < 3, semigroupoids >= 5.0.1 && < 7, strict >= 0.4 && < 0.6, tagged >= 0.8.6 && < 1, template-haskell >= 2.11.1.0 && < 2.22, text >= 1.2.3.0 && < 2.1, th-abstraction >= 0.4.1 && < 0.7, these >= 1.1.1.1 && < 1.3, transformers >= 0.5.0.0 && < 0.7, transformers-compat >= 0.5.0.4 && < 1, unordered-containers >= 0.2.10 && < 0.3, vector >= 0.12.1.2 && < 0.14 -- Control.Lens as the first module, so cabal repl loads it. exposed-modules: Control.Lens exposed-modules: Control.Exception.Lens Control.Lens.At Control.Lens.Combinators Control.Lens.Cons Control.Lens.Each Control.Lens.Empty Control.Lens.Equality Control.Lens.Extras Control.Lens.Fold Control.Lens.Getter Control.Lens.Indexed Control.Lens.Internal Control.Lens.Internal.Bazaar Control.Lens.Internal.ByteString Control.Lens.Internal.Context Control.Lens.Internal.CTypes Control.Lens.Internal.Deque Control.Lens.Internal.Doctest Control.Lens.Internal.Exception Control.Lens.Internal.FieldTH Control.Lens.Internal.PrismTH 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.List Control.Lens.Internal.Magma Control.Lens.Internal.Prism Control.Lens.Internal.Profunctor Control.Lens.Internal.Review Control.Lens.Internal.Setter Control.Lens.Internal.TH Control.Lens.Internal.Zoom Control.Lens.Iso Control.Lens.Lens Control.Lens.Level Control.Lens.Operators Control.Lens.Plated Control.Lens.Prism Control.Lens.Profunctor Control.Lens.Reified Control.Lens.Review Control.Lens.Setter Control.Lens.TH Control.Lens.Traversal Control.Lens.Tuple Control.Lens.Type Control.Lens.Unsound Control.Lens.Wrapped 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.Map.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 GHC.Generics.Lens System.Exit.Lens System.FilePath.Lens System.IO.Error.Lens Language.Haskell.TH.Lens Numeric.Lens Numeric.Natural.Lens other-modules: Control.Lens.Internal.Prelude if flag(trustworthy) && impl(ghc) other-extensions: Trustworthy cpp-options: -DTRUSTWORTHY=1 if flag(inlining) cpp-options: -DINLINING if flag(j) ghc-options: -j4 ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10 -Wno-trustworthy-safe -Wmissing-pattern-synonym-signatures -Wno-redundant-constraints hs-source-dirs: src include-dirs: include default-language: Haskell2010 -- future proof, whether the field will be comma separated or not. x-docspec-extra-packages: simple-reflect x-docspec-extra-packages: deepseq -- Verify that Template Haskell expansion works test-suite templates type: exitcode-stdio-1.0 main-is: templates.hs other-modules: BigRecord T799 T917 T972 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 if flag(dump-splices) ghc-options: -ddump-splices if !flag(test-templates) buildable: False else build-depends: base, lens -- Verify the properties of lenses with QuickCheck test-suite properties type: exitcode-stdio-1.0 main-is: properties.hs other-modules: Control.Lens.Properties ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests lens-properties/src include-dirs: include default-language: Haskell2010 if !flag(test-properties) buildable: False else build-depends: base, lens, QuickCheck >= 2.4, test-framework >= 0.6, test-framework-quickcheck2 >= 0.2, transformers test-suite hunit type: exitcode-stdio-1.0 main-is: hunit.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests default-language: Haskell2010 if !flag(test-hunit) buildable: False else build-depends: base, containers, HUnit >= 1.2, lens, mtl, text, bytestring, test-framework >= 0.6, test-framework-hunit >= 0.2 -- We need this dummy test-suite to add simple-reflect to the install plan -- -- When cabal-install's extra-packages support becomes widely available -- (i.e. after 3.4 release), we can remove this test-suite. test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs hs-source-dirs: tests default-language: Haskell2010 build-depends: base, deepseq, simple-reflect >= 0.3.1 -- 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 default-language: Haskell2010 build-depends: base, base-compat >=0.11.0 && <0.14, 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: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks default-language: Haskell2010 build-depends: base, comonad >= 4, criterion, deepseq, lens, transformers -- Benchmarking folds benchmark folds type: exitcode-stdio-1.0 main-is: folds.hs ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks default-language: Haskell2010 build-depends: base, criterion, containers, bytestring, unordered-containers, vector, lens -- Benchmarking traversals benchmark traversals type: exitcode-stdio-1.0 main-is: traversals.hs ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks default-language: Haskell2010 build-depends: base, criterion, containers, deepseq, bytestring, unordered-containers, vector, lens -- Benchmarking unsafe implementation strategies benchmark unsafe type: exitcode-stdio-1.0 main-is: unsafe.hs ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks default-language: Haskell2010 build-depends: base, comonad >= 4, criterion >= 1, deepseq, generic-deriving, lens, transformers lens-5.2.3/src/Control/Exception/0000755000000000000000000000000007346545000015020 5ustar0000000000000000lens-5.2.3/src/Control/Exception/Lens.hs0000644000000000000000000015055107346545000016264 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens -- Copyright : (C) 2012-16 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 -- 'MonadCatch' instead of just 'Prelude.IO'. This enables them to be used -- more easily in 'Monad' transformer stacks. ---------------------------------------------------------------------------- module Control.Exception.Lens ( -- * Handling catching, catching_ , handling, handling_ -- * Trying , trying, trying_ -- * Throwing , throwing , throwing_ , throwingM , throwingTo -- * Mapping , mappedException, mappedException' -- * Exceptions , exception , pattern Exception -- * Exception Handlers , Handleable(..) -- ** IOExceptions , AsIOException(..) , pattern IOException_ -- ** Arithmetic Exceptions , AsArithException(..) , _Overflow, _Underflow, _LossOfPrecision, _DivideByZero, _Denormal , _RatioZeroDenominator , pattern ArithException_ , pattern Overflow_ , pattern Underflow_ , pattern LossOfPrecision_ , pattern DivideByZero_ , pattern Denormal_ , pattern RatioZeroDenominator_ -- ** Array Exceptions , AsArrayException(..) , _IndexOutOfBounds , _UndefinedElement , pattern ArrayException_ , pattern IndexOutOfBounds_ , pattern UndefinedElement_ -- ** Assertion Failed , AsAssertionFailed(..) , pattern AssertionFailed__ , pattern AssertionFailed_ -- ** Async Exceptions , AsAsyncException(..) , _StackOverflow , _HeapOverflow , _ThreadKilled , _UserInterrupt , pattern AsyncException_ , pattern StackOverflow_ , pattern HeapOverflow_ , pattern ThreadKilled_ , pattern UserInterrupt_ -- ** Non-Termination , AsNonTermination(..) , pattern NonTermination__ , pattern NonTermination_ -- ** Nested Atomically , AsNestedAtomically(..) , pattern NestedAtomically__ , pattern NestedAtomically_ -- ** Blocked Indefinitely -- *** on MVar , AsBlockedIndefinitelyOnMVar(..) , pattern BlockedIndefinitelyOnMVar__ , pattern BlockedIndefinitelyOnMVar_ -- *** on STM , AsBlockedIndefinitelyOnSTM(..) , pattern BlockedIndefinitelyOnSTM__ , pattern BlockedIndefinitelyOnSTM_ -- ** Deadlock , AsDeadlock(..) , pattern Deadlock__ , pattern Deadlock_ -- ** No Such Method , AsNoMethodError(..) , pattern NoMethodError__ , pattern NoMethodError_ -- ** Pattern Match Failure , AsPatternMatchFail(..) , pattern PatternMatchFail__ , pattern PatternMatchFail_ -- ** Record , AsRecConError(..) , AsRecSelError(..) , AsRecUpdError(..) , pattern RecConError__ , pattern RecConError_ , pattern RecSelError__ , pattern RecSelError_ , pattern RecUpdError__ , pattern RecUpdError_ -- ** Error Call , AsErrorCall(..) , pattern ErrorCall__ , pattern ErrorCall_ -- ** Allocation Limit Exceeded , AsAllocationLimitExceeded(..) , pattern AllocationLimitExceeded__ , pattern AllocationLimitExceeded_ -- ** Type Error , AsTypeError(..) , pattern TypeError__ , pattern TypeError_ #if MIN_VERSION_base(4,10,0) -- ** Compaction Failed , AsCompactionFailed(..) , pattern CompactionFailed__ , pattern CompactionFailed_ #endif -- * Handling Exceptions , AsHandlingException(..) , pattern HandlingException__ , pattern HandlingException_ ) where import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch as Catch import Control.Exception as Exception hiding (try, tryJust, catchJust) import Control.Lens import Control.Lens.Internal.Exception import Data.Monoid import GHC.Conc (ThreadId) import Prelude ( const, either, flip, id , (.) , Maybe(..), Either(..), String , Bool(..) ) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Applicative -- >>> :m + Control.Exception Control.Monad Data.List Prelude ------------------------------------------------------------------------------ -- Exceptions as Prisms ------------------------------------------------------------------------------ -- | Traverse the strongly typed t'Exception' contained in 'SomeException' where the type of your function matches -- the desired t'Exception'. -- -- @ -- 'exception' :: ('Applicative' f, t'Exception' a) -- => (a -> f a) -> 'SomeException' -> f 'SomeException' -- @ exception :: Exception a => Prism' SomeException a exception = prism' toException fromException {-# INLINE exception #-} pattern Exception :: Exception a => a -> SomeException pattern Exception e <- (preview exception -> Just e) where Exception e = review exception e ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ -- | Catch exceptions that match a given t'Prism' (or any t'Fold', really). -- -- >>> catching _AssertionFailed (assert False (return "uncaught")) $ \ _ -> return "caught" -- "caught" -- -- @ -- 'catching' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r -- @ catching :: MonadCatch m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} -- | Catch exceptions that match a given t'Prism' (or any t'Getter'), discarding -- the information about the match. This is particularly useful when you have -- a @'Prism'' e ()@ where the result of the t'Prism' or t'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- >>> catching_ _AssertionFailed (assert False (return "uncaught")) $ return "caught" -- "caught" -- -- @ -- 'catching_' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m r -> m r -- @ catching_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} ------------------------------------------------------------------------------ -- 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' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r -- @ handling :: MonadCatch m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} -- | 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_' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m r -> m r -- @ handling_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} ------------------------------------------------------------------------------ -- Trying ------------------------------------------------------------------------------ -- | A variant of 'Control.Exception.try' that takes a t'Prism' (or any t'Fold') to select which -- exceptions are caught (c.f. 'Control.Exception.tryJust', 'Control.Exception.catchJust'). If the -- t'Exception' does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m ('Either' a r) -- @ trying :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Either a r) trying l = tryJust (preview l) {-# INLINE trying #-} -- | A version of 'trying' that discards the specific exception thrown. -- -- @ -- 'trying_' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m (Maybe r) -- @ trying_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Maybe r) trying_ l m = preview _Right `liftM` trying l m {-# INLINE trying_ #-} ------------------------------------------------------------------------------ -- Throwing ------------------------------------------------------------------------------ -- | Throw an t'Exception' described by a t'Prism'. Exceptions may be thrown from -- purely functional code, but may only be caught within the 'Prelude.IO' 'Monad'. -- -- @ -- 'throwing' l ≡ 'reviews' l 'throw' -- @ -- -- @ -- 'throwing' :: 'Prism'' 'SomeException' t -> t -> r -- 'throwing' :: 'Iso'' 'SomeException' t -> t -> r -- @ throwing :: AReview SomeException b -> b -> r throwing l = reviews l Exception.throw {-# INLINE throwing #-} -- | Similar to 'throwing' but specialised for the common case of -- error constructors with no arguments. -- -- @ -- data MyError = Foo | Bar -- makePrisms ''MyError -- 'throwing_' _Foo :: 'Control.Monad.Error.Class.MonadError' MyError m => m a -- @ throwing_ :: AReview SomeException () -> m x throwing_ l = throwing l () {-# INLINE throwing_ #-} -- | A variant of 'throwing' that can only be used within the 'Prelude.IO' 'Monad' -- (or any other 'MonadCatch' instance) to throw an t'Exception' described -- by a t'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 t'Exception' @e@ to be raised, whereas the -- second one won't. In fact, 'throwingM' will only cause an t'Exception' to -- be raised when it is used within the 'MonadCatch' instance. The 'throwingM' -- variant should be used in preference to 'throwing' to raise an t'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' :: 'MonadThrow' m => 'Prism'' 'SomeException' t -> t -> m r -- 'throwingM' :: 'MonadThrow' m => 'Iso'' 'SomeException' t -> t -> m r -- @ throwingM :: MonadThrow m => AReview SomeException b -> b -> m r throwingM l = reviews l throwM {-# INLINE throwingM #-} -- | 'throwingTo' raises an t'Exception' specified by a t'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 SomeException b -> b -> m () throwingTo tid l = reviews l (liftIO . throwTo tid) {-# INLINE throwingTo #-} ---------------------------------------------------------------------------- -- Mapping ---------------------------------------------------------------------------- -- | This t'Setter' can be used to purely map over the t'Exception's an -- arbitrary expression might throw; it is a variant of 'mapException' in -- the same way that 'mapped' is a variant of 'fmap'. -- -- > 'mapException' ≡ 'over' 'mappedException' -- -- This view that every Haskell expression can be regarded as carrying a bag -- of t'Exception's is detailed in “A Semantics for Imprecise Exceptions” by -- Peyton Jones & al. at PLDI ’99. -- -- The following maps failed assertions to arithmetic overflow: -- -- >>> handling _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & mappedException %~ \ (AssertionFailed _) -> Overflow -- "caught" mappedException :: (Exception e, Exception e') => Setter s s e e' mappedException = sets mapException {-# INLINE mappedException #-} -- | This is a type restricted version of 'mappedException', which avoids -- the type ambiguity in the input t'Exception' when using 'set'. -- -- The following maps any exception to arithmetic overflow: -- -- >>> handling _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & mappedException' .~ Overflow -- "caught" mappedException' :: Exception e' => Setter s s SomeException e' mappedException' = mappedException {-# INLINE mappedException' #-} ---------------------------------------------------------------------------- -- IOException ---------------------------------------------------------------------------- -- | Exceptions that occur in the 'Prelude.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 t where -- | Unfortunately the name 'GHC.IO.Exception.ioException' is taken by @base@ for -- throwing IOExceptions. -- -- @ -- '_IOException' :: 'Prism'' 'IOException' 'IOException' -- '_IOException' :: 'Prism'' 'SomeException' 'IOException' -- @ -- -- Many combinators for working with an 'IOException' are available -- in "System.IO.Error.Lens". _IOException :: Prism' t IOException instance AsIOException IOException where _IOException = id {-# INLINE _IOException #-} instance AsIOException SomeException where _IOException = exception {-# INLINE _IOException #-} pattern IOException_ :: AsIOException s => IOException -> s pattern IOException_ a <- (preview _IOException -> Just a) where IOException_ a = review _IOException a ---------------------------------------------------------------------------- -- ArithException ---------------------------------------------------------------------------- -- | Arithmetic exceptions. class AsArithException t where -- | -- @ -- '_ArithException' :: 'Prism'' 'ArithException' 'ArithException' -- '_ArithException' :: 'Prism'' 'SomeException' 'ArithException' -- @ _ArithException :: Prism' t ArithException pattern ArithException_ :: AsArithException s => ArithException -> s pattern ArithException_ a <- (preview _ArithException -> Just a) where ArithException_ a = review _ArithException a instance AsArithException ArithException where _ArithException = id {-# INLINE _ArithException #-} instance AsArithException SomeException where _ArithException = exception {-# INLINE _ArithException #-} -- | Handle arithmetic '_Overflow'. -- -- @ -- '_Overflow' ≡ '_ArithException' '.' '_Overflow' -- @ -- -- @ -- '_Overflow' :: 'Prism'' 'ArithException' 'ArithException' -- '_Overflow' :: 'Prism'' 'SomeException' 'ArithException' -- @ _Overflow :: AsArithException t => Prism' t () _Overflow = _ArithException . dimap seta (either id id) . right' . rmap (Overflow <$) where seta Overflow = Right () seta t = Left (pure t) {-# INLINE _Overflow #-} pattern Overflow_ :: AsArithException s => s pattern Overflow_ <- (has _Overflow -> True) where Overflow_ = review _Overflow () -- | Handle arithmetic '_Underflow'. -- -- @ -- '_Underflow' ≡ '_ArithException' '.' '_Underflow' -- @ -- -- @ -- '_Underflow' :: 'Prism'' 'ArithException' 'ArithException' -- '_Underflow' :: 'Prism'' 'SomeException' 'ArithException' -- @ _Underflow :: AsArithException t => Prism' t () _Underflow = _ArithException . dimap seta (either id id) . right' . rmap (Underflow <$) where seta Underflow = Right () seta t = Left (pure t) {-# INLINE _Underflow #-} pattern Underflow_ :: AsArithException s => s pattern Underflow_ <- (has _Underflow -> True) where Underflow_ = review _Underflow () -- | Handle arithmetic loss of precision. -- -- @ -- '_LossOfPrecision' ≡ '_ArithException' '.' '_LossOfPrecision' -- @ -- -- @ -- '_LossOfPrecision' :: 'Prism'' 'ArithException' 'ArithException' -- '_LossOfPrecision' :: 'Prism'' 'SomeException' 'ArithException' -- @ _LossOfPrecision :: AsArithException t => Prism' t () _LossOfPrecision = _ArithException . dimap seta (either id id) . right' . rmap (LossOfPrecision <$) where seta LossOfPrecision = Right () seta t = Left (pure t) {-# INLINE _LossOfPrecision #-} pattern LossOfPrecision_ :: AsArithException s => s pattern LossOfPrecision_ <- (has _LossOfPrecision -> True) where LossOfPrecision_ = review _LossOfPrecision () -- | Handle division by zero. -- -- @ -- '_DivideByZero' ≡ '_ArithException' '.' '_DivideByZero' -- @ -- -- @ -- '_DivideByZero' :: 'Prism'' 'ArithException' 'ArithException' -- '_DivideByZero' :: 'Prism'' 'SomeException' 'ArithException' -- @ _DivideByZero :: AsArithException t => Prism' t () _DivideByZero = _ArithException . dimap seta (either id id) . right' . rmap (DivideByZero <$) where seta DivideByZero = Right () seta t = Left (pure t) {-# INLINE _DivideByZero #-} pattern DivideByZero_ :: AsArithException s => s pattern DivideByZero_ <- (has _DivideByZero -> True) where DivideByZero_ = review _DivideByZero () -- | Handle exceptional _Denormalized floating pure. -- -- @ -- '_Denormal' ≡ '_ArithException' '.' '_Denormal' -- @ -- -- @ -- '_Denormal' :: 'Prism'' 'ArithException' 'ArithException' -- '_Denormal' :: 'Prism'' 'SomeException' 'ArithException' -- @ _Denormal :: AsArithException t => Prism' t () _Denormal = _ArithException . dimap seta (either id id) . right' . rmap (Denormal <$) where seta Denormal = Right () seta t = Left (pure t) {-# INLINE _Denormal #-} pattern Denormal_ :: AsArithException s => s pattern Denormal_ <- (has _Denormal -> True) where Denormal_ = review _Denormal () -- | -- -- @ -- '_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator' -- @ -- -- @ -- '_RatioZeroDenominator' :: 'Prism'' 'ArithException' 'ArithException' -- '_RatioZeroDenominator' :: 'Prism'' 'SomeException' 'ArithException' -- @ _RatioZeroDenominator :: AsArithException t => Prism' t () _RatioZeroDenominator = _ArithException . dimap seta (either id id) . right' . rmap (RatioZeroDenominator <$) where seta RatioZeroDenominator = Right () seta t = Left (pure t) {-# INLINE _RatioZeroDenominator #-} pattern RatioZeroDenominator_ :: AsArithException s => s pattern RatioZeroDenominator_ <- (has _RatioZeroDenominator -> True) where RatioZeroDenominator_ = review _RatioZeroDenominator () ---------------------------------------------------------------------------- -- ArrayException ---------------------------------------------------------------------------- -- | Exceptions generated by array operations. class AsArrayException t where -- | Extract information about an 'ArrayException'. -- -- @ -- '_ArrayException' :: 'Prism'' 'ArrayException' 'ArrayException' -- '_ArrayException' :: 'Prism'' 'SomeException' 'ArrayException' -- @ _ArrayException :: Prism' t ArrayException instance AsArrayException ArrayException where _ArrayException = id {-# INLINE _ArrayException #-} instance AsArrayException SomeException where _ArrayException = exception {-# INLINE _ArrayException #-} pattern ArrayException_ :: AsArrayException s => ArrayException -> s pattern ArrayException_ e <- (preview _ArrayException -> Just e) where ArrayException_ e = review _ArrayException e -- | 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 t => Prism' t String _IndexOutOfBounds = _ArrayException . dimap seta (either id id) . right' . rmap (fmap IndexOutOfBounds) where seta (IndexOutOfBounds r) = Right r seta t = Left (pure t) {-# INLINE _IndexOutOfBounds #-} pattern IndexOutOfBounds_ :: AsArrayException s => String -> s pattern IndexOutOfBounds_ e <- (preview _IndexOutOfBounds -> Just e) where IndexOutOfBounds_ e = review _IndexOutOfBounds e -- | 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 t => Prism' t String _UndefinedElement = _ArrayException . dimap seta (either id id) . right' . rmap (fmap UndefinedElement) where seta (UndefinedElement r) = Right r seta t = Left (pure t) {-# INLINE _UndefinedElement #-} pattern UndefinedElement_ :: AsArrayException s => String -> s pattern UndefinedElement_ e <- (preview _UndefinedElement -> Just e) where UndefinedElement_ e = review _UndefinedElement e ---------------------------------------------------------------------------- -- AssertionFailed ---------------------------------------------------------------------------- -- | 'assert' was applied to 'Prelude.False'. class AsAssertionFailed t where -- | -- @ -- '__AssertionFailed' :: 'Prism'' 'AssertionFailed' 'AssertionFailed' -- '__AssertionFailed' :: 'Prism'' 'SomeException' 'AssertionFailed' -- @ __AssertionFailed :: Prism' t AssertionFailed -- | This t'Exception' contains provides information about what assertion failed in the 'String'. -- -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("" `isInfixOf` xs) ) $ assert False (return "uncaught") -- "caught" -- -- @ -- '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String' -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' -- @ _AssertionFailed :: Prism' t String _AssertionFailed = __AssertionFailed._AssertionFailed {-# INLINE _AssertionFailed #-} instance AsAssertionFailed AssertionFailed where __AssertionFailed = id {-# INLINE __AssertionFailed #-} _AssertionFailed = _Wrapping AssertionFailed {-# INLINE _AssertionFailed #-} instance AsAssertionFailed SomeException where __AssertionFailed = exception {-# INLINE __AssertionFailed #-} pattern AssertionFailed__ :: AsAssertionFailed s => AssertionFailed -> s pattern AssertionFailed__ e <- (preview __AssertionFailed -> Just e) where AssertionFailed__ e = review __AssertionFailed e pattern AssertionFailed_ :: AsAssertionFailed s => String -> s pattern AssertionFailed_ e <- (preview _AssertionFailed -> Just e) where AssertionFailed_ e = review _AssertionFailed e ---------------------------------------------------------------------------- -- AsyncException ---------------------------------------------------------------------------- -- | Asynchronous exceptions. class AsAsyncException t where -- | There are several types of 'AsyncException'. -- -- @ -- '_AsyncException' :: 'Equality'' 'AsyncException' 'AsyncException' -- '_AsyncException' :: 'Prism'' 'SomeException' 'AsyncException' -- @ _AsyncException :: Prism' t AsyncException instance AsAsyncException AsyncException where _AsyncException = id {-# INLINE _AsyncException #-} instance AsAsyncException SomeException where _AsyncException = exception {-# INLINE _AsyncException #-} pattern AsyncException_ :: AsAsyncException s => AsyncException -> s pattern AsyncException_ e <- (preview _AsyncException -> Just e) where AsyncException_ e = review _AsyncException e -- | The current thread's stack exceeded its limit. Since an t'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 t => Prism' t () _StackOverflow = _AsyncException . dimap seta (either id id) . right' . rmap (StackOverflow <$) where seta StackOverflow = Right () seta t = Left (pure t) {-# INLINE _StackOverflow #-} pattern StackOverflow_ :: AsAsyncException s => s pattern StackOverflow_ <- (has _StackOverflow -> True) where StackOverflow_ = review _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 t'Exception'. -- -- * GHC currently does not throw 'HeapOverflow' exceptions. -- -- @ -- '_HeapOverflow' :: 'Prism'' 'AsyncException' () -- '_HeapOverflow' :: 'Prism'' 'SomeException' () -- @ _HeapOverflow :: AsAsyncException t => Prism' t () _HeapOverflow = _AsyncException . dimap seta (either id id) . right' . rmap (HeapOverflow <$) where seta HeapOverflow = Right () seta t = Left (pure t) {-# INLINE _HeapOverflow #-} pattern HeapOverflow_ :: AsAsyncException s => s pattern HeapOverflow_ <- (has _HeapOverflow -> True) where HeapOverflow_ = review _HeapOverflow () -- | This t'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 t => Prism' t () _ThreadKilled = _AsyncException . dimap seta (either id id) . right' . rmap (ThreadKilled <$) where seta ThreadKilled = Right () seta t = Left (pure t) {-# INLINE _ThreadKilled #-} pattern ThreadKilled_ :: AsAsyncException s => s pattern ThreadKilled_ <- (has _ThreadKilled -> True) where ThreadKilled_ = review _ThreadKilled () -- | This t'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 t => Prism' t () _UserInterrupt = _AsyncException . dimap seta (either id id) . right' . rmap (UserInterrupt <$) where seta UserInterrupt = Right () seta t = Left (pure t) {-# INLINE _UserInterrupt #-} pattern UserInterrupt_ :: AsAsyncException s => s pattern UserInterrupt_ <- (has _UserInterrupt -> True) where UserInterrupt_ = review _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 AsNonTermination t where -- | -- @ -- '__NonTermination' :: 'Prism'' 'NonTermination' 'NonTermination' -- '__NonTermination' :: 'Prism'' 'SomeException' 'NonTermination' -- @ __NonTermination :: Prism' t NonTermination -- | There is no additional information carried in a 'NonTermination' t'Exception'. -- -- @ -- '_NonTermination' :: 'Prism'' 'NonTermination' () -- '_NonTermination' :: 'Prism'' 'SomeException' () -- @ _NonTermination :: Prism' t () _NonTermination = __NonTermination._NonTermination {-# INLINE _NonTermination #-} instance AsNonTermination NonTermination where __NonTermination = id {-# INLINE __NonTermination #-} _NonTermination = trivial NonTermination {-# INLINE _NonTermination #-} instance AsNonTermination SomeException where __NonTermination = exception {-# INLINE __NonTermination #-} pattern NonTermination__ :: AsNonTermination s => NonTermination -> s pattern NonTermination__ e <- (preview __NonTermination -> Just e) where NonTermination__ e = review __NonTermination e pattern NonTermination_ :: AsNonTermination s => s pattern NonTermination_ <- (has _NonTermination -> True) where NonTermination_ = review _NonTermination () ---------------------------------------------------------------------------- -- NestedAtomically ---------------------------------------------------------------------------- -- | Thrown when the program attempts to call atomically, from the -- 'Control.Monad.STM' package, inside another call to atomically. class AsNestedAtomically t where -- | -- @ -- '__NestedAtomically' :: 'Prism'' 'NestedAtomically' 'NestedAtomically' -- '__NestedAtomically' :: 'Prism'' 'SomeException' 'NestedAtomically' -- @ __NestedAtomically :: Prism' t NestedAtomically -- | There is no additional information carried in a 'NestedAtomically' t'Exception'. -- -- @ -- '_NestedAtomically' :: 'Prism'' 'NestedAtomically' () -- '_NestedAtomically' :: 'Prism'' 'SomeException' () -- @ _NestedAtomically :: Prism' t () _NestedAtomically = __NestedAtomically._NestedAtomically {-# INLINE _NestedAtomically #-} instance AsNestedAtomically NestedAtomically where __NestedAtomically = id {-# INLINE __NestedAtomically #-} _NestedAtomically = trivial NestedAtomically {-# INLINE _NestedAtomically #-} instance AsNestedAtomically SomeException where __NestedAtomically = exception {-# INLINE __NestedAtomically #-} pattern NestedAtomically__ :: AsNestedAtomically s => NestedAtomically -> s pattern NestedAtomically__ e <- (preview __NestedAtomically -> Just e) where NestedAtomically__ e = review __NestedAtomically e pattern NestedAtomically_ :: AsNestedAtomically s => s pattern NestedAtomically_ <- (has _NestedAtomically -> True) where NestedAtomically_ = review _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 AsBlockedIndefinitelyOnMVar t where -- | -- @ -- '__BlockedIndefinitelyOnMVar' :: 'Prism'' 'BlockedIndefinitelyOnMVar' 'BlockedIndefinitelyOnMVar' -- '__BlockedIndefinitelyOnMVar' :: 'Prism'' 'SomeException' 'BlockedIndefinitelyOnMVar' -- @ __BlockedIndefinitelyOnMVar :: Prism' t BlockedIndefinitelyOnMVar -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' t'Exception'. -- -- @ -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'BlockedIndefinitelyOnMVar' () -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'SomeException' () -- @ _BlockedIndefinitelyOnMVar :: Prism' t () _BlockedIndefinitelyOnMVar = __BlockedIndefinitelyOnMVar._BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} instance AsBlockedIndefinitelyOnMVar BlockedIndefinitelyOnMVar where __BlockedIndefinitelyOnMVar = id {-# INLINE __BlockedIndefinitelyOnMVar #-} _BlockedIndefinitelyOnMVar = trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} instance AsBlockedIndefinitelyOnMVar SomeException where __BlockedIndefinitelyOnMVar = exception {-# INLINE __BlockedIndefinitelyOnMVar #-} pattern BlockedIndefinitelyOnMVar__ :: AsBlockedIndefinitelyOnMVar s => BlockedIndefinitelyOnMVar -> s pattern BlockedIndefinitelyOnMVar__ e <- (preview __BlockedIndefinitelyOnMVar -> Just e) where BlockedIndefinitelyOnMVar__ e = review __BlockedIndefinitelyOnMVar e pattern BlockedIndefinitelyOnMVar_ :: AsBlockedIndefinitelyOnMVar s => s pattern BlockedIndefinitelyOnMVar_ <- (has _BlockedIndefinitelyOnMVar -> True) where BlockedIndefinitelyOnMVar_ = review _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 AsBlockedIndefinitelyOnSTM t where -- | -- @ -- '__BlockedIndefinitelyOnSTM' :: 'Prism'' 'BlockedIndefinitelyOnSTM' 'BlockedIndefinitelyOnSTM' -- '__BlockedIndefinitelyOnSTM' :: 'Prism'' 'SomeException' 'BlockedIndefinitelyOnSTM' -- @ __BlockedIndefinitelyOnSTM :: Prism' t BlockedIndefinitelyOnSTM -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' t'Exception'. -- -- @ -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'BlockedIndefinitelyOnSTM' () -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'SomeException' () -- @ _BlockedIndefinitelyOnSTM :: Prism' t () _BlockedIndefinitelyOnSTM = __BlockedIndefinitelyOnSTM._BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} instance AsBlockedIndefinitelyOnSTM BlockedIndefinitelyOnSTM where __BlockedIndefinitelyOnSTM = id {-# INLINE __BlockedIndefinitelyOnSTM #-} _BlockedIndefinitelyOnSTM = trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} instance AsBlockedIndefinitelyOnSTM SomeException where __BlockedIndefinitelyOnSTM = exception {-# INLINE __BlockedIndefinitelyOnSTM #-} pattern BlockedIndefinitelyOnSTM__ :: AsBlockedIndefinitelyOnSTM s => BlockedIndefinitelyOnSTM -> s pattern BlockedIndefinitelyOnSTM__ e <- (preview __BlockedIndefinitelyOnSTM -> Just e) where BlockedIndefinitelyOnSTM__ e = review __BlockedIndefinitelyOnSTM e pattern BlockedIndefinitelyOnSTM_ :: AsBlockedIndefinitelyOnSTM s => s pattern BlockedIndefinitelyOnSTM_ <- (has _BlockedIndefinitelyOnSTM -> True) where BlockedIndefinitelyOnSTM_ = review _BlockedIndefinitelyOnSTM () ---------------------------------------------------------------------------- -- Deadlock ---------------------------------------------------------------------------- -- | There are no runnable threads, so the program is deadlocked. The -- 'Deadlock' t'Exception' is raised in the main thread only. class AsDeadlock t where -- | -- @ -- '__Deadlock' :: 'Prism'' 'Deadlock' 'Deadlock' -- '__Deadlock' :: 'Prism'' 'SomeException' 'Deadlock' -- @ __Deadlock :: Prism' t Deadlock -- | There is no information carried in a 'Deadlock' t'Exception'. -- -- @ -- '_Deadlock' :: 'Prism'' 'Deadlock' () -- '_Deadlock' :: 'Prism'' 'SomeException' () -- @ _Deadlock :: Prism' t () _Deadlock = __Deadlock._Deadlock {-# INLINE _Deadlock #-} instance AsDeadlock Deadlock where __Deadlock = id {-# INLINE __Deadlock #-} _Deadlock = trivial Deadlock {-# INLINE _Deadlock #-} instance AsDeadlock SomeException where __Deadlock = exception {-# INLINE __Deadlock #-} pattern Deadlock__ :: AsDeadlock s => Deadlock -> s pattern Deadlock__ e <- (preview __Deadlock -> Just e) where Deadlock__ e = review __Deadlock e pattern Deadlock_ :: AsDeadlock s => s pattern Deadlock_ <- (has _Deadlock -> True) where Deadlock_ = review _Deadlock () ---------------------------------------------------------------------------- -- NoMethodError ---------------------------------------------------------------------------- -- | A class method without a definition (neither a default definition, -- nor a definition in the appropriate instance) was called. class AsNoMethodError t where -- | -- @ -- '__NoMethodError' :: 'Prism'' 'NoMethodError' 'NoMethodError' -- '__NoMethodError' :: 'Prism'' 'SomeException' 'NoMethodError' -- @ __NoMethodError :: Prism' t NoMethodError -- | Extract a description of the missing method. -- -- @ -- '_NoMethodError' :: 'Prism'' 'NoMethodError' 'String' -- '_NoMethodError' :: 'Prism'' 'SomeException' 'String' -- @ _NoMethodError :: Prism' t String _NoMethodError = __NoMethodError._NoMethodError {-# INLINE _NoMethodError #-} instance AsNoMethodError NoMethodError where __NoMethodError = id {-# INLINE __NoMethodError #-} _NoMethodError = _Wrapping NoMethodError {-# INLINE _NoMethodError #-} instance AsNoMethodError SomeException where __NoMethodError = exception {-# INLINE __NoMethodError #-} pattern NoMethodError__ :: AsNoMethodError s => NoMethodError -> s pattern NoMethodError__ e <- (preview __NoMethodError -> Just e) where NoMethodError__ e = review __NoMethodError e pattern NoMethodError_ :: AsNoMethodError s => String -> s pattern NoMethodError_ e <- (preview _NoMethodError -> Just e) where NoMethodError_ e = review _NoMethodError e ---------------------------------------------------------------------------- -- PatternMatchFail ---------------------------------------------------------------------------- -- | A pattern match failed. class AsPatternMatchFail t where -- | -- @ -- '__PatternMatchFail' :: 'Prism'' 'PatternMatchFail' 'PatternMatchFail' -- '__PatternMatchFail' :: 'Prism'' 'SomeException' 'PatternMatchFail' -- @ __PatternMatchFail :: Prism' t PatternMatchFail -- | Information about the source location of the pattern. -- -- @ -- '_PatternMatchFail' :: 'Prism'' 'PatternMatchFail' 'String' -- '_PatternMatchFail' :: 'Prism'' 'SomeException' 'String' -- @ _PatternMatchFail :: Prism' t String _PatternMatchFail = __PatternMatchFail._PatternMatchFail {-# INLINE _PatternMatchFail #-} instance AsPatternMatchFail PatternMatchFail where __PatternMatchFail = id {-# INLINE __PatternMatchFail #-} _PatternMatchFail = _Wrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} instance AsPatternMatchFail SomeException where __PatternMatchFail = exception {-# INLINE __PatternMatchFail #-} pattern PatternMatchFail__ :: AsPatternMatchFail s => PatternMatchFail -> s pattern PatternMatchFail__ e <- (preview __PatternMatchFail -> Just e) where PatternMatchFail__ e = review __PatternMatchFail e pattern PatternMatchFail_ :: AsPatternMatchFail s => String -> s pattern PatternMatchFail_ e <- (preview _PatternMatchFail -> Just e) where PatternMatchFail_ e = review _PatternMatchFail e ---------------------------------------------------------------------------- -- RecConError ---------------------------------------------------------------------------- -- | An uninitialised record field was used. class AsRecConError t where -- | -- @ -- '__RecConError' :: 'Prism'' 'RecConError' 'RecConError' -- '__RecConError' :: 'Prism'' 'SomeException' 'RecConError' -- @ __RecConError :: Prism' t RecConError -- | Information about the source location where the record was -- constructed. -- -- @ -- '_RecConError' :: 'Prism'' 'RecConError' 'String' -- '_RecConError' :: 'Prism'' 'SomeException' 'String' -- @ _RecConError :: Prism' t String _RecConError = __RecConError._RecConError {-# INLINE _RecConError #-} instance AsRecConError RecConError where __RecConError = id {-# INLINE __RecConError #-} _RecConError = _Wrapping RecConError {-# INLINE _RecConError #-} instance AsRecConError SomeException where __RecConError = exception {-# INLINE __RecConError #-} pattern RecConError__ :: AsRecConError s => RecConError -> s pattern RecConError__ e <- (preview __RecConError -> Just e) where RecConError__ e = review __RecConError e pattern RecConError_ :: AsRecConError s => String -> s pattern RecConError_ e <- (preview _RecConError -> Just e) where RecConError_ e = review _RecConError e ---------------------------------------------------------------------------- -- 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 AsRecSelError t where -- | -- @ -- '__RecSelError' :: 'Prism'' 'RecSelError' 'RecSelError' -- '__RecSelError' :: 'Prism'' 'SomeException' 'RecSelError' -- @ __RecSelError :: Prism' t RecSelError -- | Information about the source location where the record selection occurred. -- -- @ -- '_RecSelError' :: 'Prism'' 'RecSelError' 'String' -- '_RecSelError' :: 'Prism'' 'SomeException' 'String' -- @ _RecSelError :: Prism' t String _RecSelError = __RecSelError._RecSelError {-# INLINE _RecSelError #-} instance AsRecSelError RecSelError where __RecSelError = id {-# INLINE __RecSelError #-} _RecSelError = _Wrapping RecSelError {-# INLINE _RecSelError #-} instance AsRecSelError SomeException where __RecSelError = exception {-# INLINE __RecSelError #-} pattern RecSelError__ :: AsRecSelError s => RecSelError -> s pattern RecSelError__ e <- (preview __RecSelError -> Just e) where RecSelError__ e = review __RecSelError e pattern RecSelError_ :: AsRecSelError s => String -> s pattern RecSelError_ e <- (preview _RecSelError -> Just e) where RecSelError_ e = review _RecSelError e ---------------------------------------------------------------------------- -- 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 AsRecUpdError t where -- | -- @ -- '__RecUpdError' :: 'Prism'' 'RecUpdError' 'RecUpdError' -- '__RecUpdError' :: 'Prism'' 'SomeException' 'RecUpdError' -- @ __RecUpdError :: Prism' t RecUpdError -- | Information about the source location where the record was updated. -- -- @ -- '_RecUpdError' :: 'Prism'' 'RecUpdError' 'String' -- '_RecUpdError' :: 'Prism'' 'SomeException' 'String' -- @ _RecUpdError :: Prism' t String _RecUpdError = __RecUpdError._RecUpdError {-# INLINE _RecUpdError #-} instance AsRecUpdError RecUpdError where __RecUpdError = id {-# INLINE __RecUpdError #-} _RecUpdError = _Wrapping RecUpdError {-# INLINE _RecUpdError #-} instance AsRecUpdError SomeException where __RecUpdError = exception {-# INLINE __RecUpdError #-} pattern RecUpdError__ :: AsRecUpdError s => RecUpdError -> s pattern RecUpdError__ e <- (preview __RecUpdError -> Just e) where RecUpdError__ e = review __RecUpdError e pattern RecUpdError_ :: AsRecUpdError s => String -> s pattern RecUpdError_ e <- (preview _RecUpdError -> Just e) where RecUpdError_ e = review _RecUpdError e ---------------------------------------------------------------------------- -- ErrorCall ---------------------------------------------------------------------------- -- | This is thrown when the user calls 'Prelude.error'. class AsErrorCall t where -- | -- @ -- '__ErrorCall' :: 'Prism'' 'ErrorCall' 'ErrorCall' -- '__ErrorCall' :: 'Prism'' 'SomeException' 'ErrorCall' -- @ __ErrorCall :: Prism' t ErrorCall -- | Retrieve the argument given to 'Prelude.error'. -- -- 'ErrorCall' is isomorphic to a 'String'. -- -- >>> catching _ErrorCall (error "touch down!") return -- "touch down!" -- -- @ -- '_ErrorCall' :: 'Prism'' 'ErrorCall' 'String' -- '_ErrorCall' :: 'Prism'' 'SomeException' 'String' -- @ _ErrorCall :: Prism' t String _ErrorCall = __ErrorCall._ErrorCall {-# INLINE _ErrorCall #-} instance AsErrorCall ErrorCall where __ErrorCall = id {-# INLINE __ErrorCall #-} _ErrorCall = _Wrapping ErrorCall {-# INLINE _ErrorCall #-} instance AsErrorCall SomeException where __ErrorCall = exception {-# INLINE __ErrorCall #-} pattern ErrorCall__ :: AsErrorCall s => ErrorCall -> s pattern ErrorCall__ e <- (preview __ErrorCall -> Just e) where ErrorCall__ e = review __ErrorCall e pattern ErrorCall_ :: AsErrorCall s => String -> s pattern ErrorCall_ e <- (preview _ErrorCall -> Just e) where ErrorCall_ e = review _ErrorCall e ---------------------------------------------------------------------------- -- AllocationLimitExceeded ---------------------------------------------------------------------------- -- | This thread has exceeded its allocation limit. class AsAllocationLimitExceeded t where -- | -- @ -- '__AllocationLimitExceeded' :: 'Prism'' 'AllocationLimitExceeded' 'AllocationLimitExceeded' -- '__AllocationLimitExceeded' :: 'Prism'' 'SomeException' 'AllocationLimitExceeded' -- @ __AllocationLimitExceeded :: Prism' t AllocationLimitExceeded -- | There is no additional information carried in an -- 'AllocationLimitExceeded' t'Exception'. -- -- @ -- '_AllocationLimitExceeded' :: 'Prism'' 'AllocationLimitExceeded' () -- '_AllocationLimitExceeded' :: 'Prism'' 'SomeException' () -- @ _AllocationLimitExceeded :: Prism' t () _AllocationLimitExceeded = __AllocationLimitExceeded._AllocationLimitExceeded {-# INLINE _AllocationLimitExceeded #-} instance AsAllocationLimitExceeded AllocationLimitExceeded where __AllocationLimitExceeded = id {-# INLINE __AllocationLimitExceeded #-} _AllocationLimitExceeded = trivial AllocationLimitExceeded {-# INLINE _AllocationLimitExceeded #-} instance AsAllocationLimitExceeded SomeException where __AllocationLimitExceeded = exception {-# INLINE __AllocationLimitExceeded #-} pattern AllocationLimitExceeded__ :: AsAllocationLimitExceeded s => AllocationLimitExceeded -> s pattern AllocationLimitExceeded__ e <- (preview __AllocationLimitExceeded -> Just e) where AllocationLimitExceeded__ e = review __AllocationLimitExceeded e pattern AllocationLimitExceeded_ :: AsAllocationLimitExceeded s => s pattern AllocationLimitExceeded_ <- (has _AllocationLimitExceeded -> True) where AllocationLimitExceeded_ = review _AllocationLimitExceeded () ---------------------------------------------------------------------------- -- TypeError ---------------------------------------------------------------------------- -- | An expression that didn't typecheck during compile time was called. -- This is only possible with @-fdefer-type-errors@. class AsTypeError t where -- | -- @ -- '__TypeError' :: 'Prism'' 'TypeError' 'TypeError' -- '__TypeError' :: 'Prism'' 'SomeException' 'TypeError' -- @ __TypeError :: Prism' t TypeError -- | Details about the failed type check. -- -- @ -- '_TypeError' :: 'Prism'' 'TypeError' 'String' -- '_TypeError' :: 'Prism'' 'SomeException' 'String' -- @ _TypeError :: Prism' t String _TypeError = __TypeError._TypeError {-# INLINE _TypeError #-} instance AsTypeError TypeError where __TypeError = id {-# INLINE __TypeError #-} _TypeError = _Wrapping TypeError {-# INLINE _TypeError #-} instance AsTypeError SomeException where __TypeError = exception {-# INLINE __TypeError #-} pattern TypeError__ :: AsTypeError s => TypeError -> s pattern TypeError__ e <- (preview __TypeError -> Just e) where TypeError__ e = review __TypeError e pattern TypeError_ :: AsTypeError s => String -> s pattern TypeError_ e <- (preview _TypeError -> Just e) where TypeError_ e = review _TypeError e #if MIN_VERSION_base(4,10,0) ---------------------------------------------------------------------------- -- CompactionFailed ---------------------------------------------------------------------------- -- | Compaction found an object that cannot be compacted. -- Functions cannot be compacted, nor can mutable objects or pinned objects. class AsCompactionFailed t where -- | -- @ -- '__CompactionFailed' :: 'Prism'' 'CompactionFailed' 'CompactionFailed' -- '__CompactionFailed' :: 'Prism'' 'SomeException' 'CompactionFailed' -- @ __CompactionFailed :: Prism' t CompactionFailed -- | Information about why a compaction failed. -- -- @ -- '_CompactionFailed' :: 'Prism'' 'CompactionFailed' 'String' -- '_CompactionFailed' :: 'Prism'' 'SomeException' 'String' -- @ _CompactionFailed :: Prism' t String _CompactionFailed = __CompactionFailed._CompactionFailed {-# INLINE _CompactionFailed #-} instance AsCompactionFailed CompactionFailed where __CompactionFailed = id {-# INLINE __CompactionFailed #-} _CompactionFailed = _Wrapping CompactionFailed {-# INLINE _CompactionFailed #-} instance AsCompactionFailed SomeException where __CompactionFailed = exception {-# INLINE __CompactionFailed #-} pattern CompactionFailed__ :: AsCompactionFailed s => CompactionFailed -> s pattern CompactionFailed__ e <- (preview __CompactionFailed -> Just e) where CompactionFailed__ e = review __CompactionFailed e pattern CompactionFailed_ :: AsCompactionFailed s => String -> s pattern CompactionFailed_ e <- (preview _CompactionFailed -> Just e) where CompactionFailed_ e = review _CompactionFailed e #endif ------------------------------------------------------------------------------ -- HandlingException ------------------------------------------------------------------------------ -- | This t'Exception' is thrown by @lens@ when the user somehow manages to rethrow -- an internal 'HandlingException'. class AsHandlingException t where -- | -- @ -- '__HandlingException' :: 'Prism'' 'HandlingException' 'HandlingException' -- '__HandlingException' :: 'Prism'' 'SomeException' 'HandlingException' -- @ __HandlingException :: Prism' t HandlingException -- | There is no information carried in a 'HandlingException'. -- -- @ -- '_HandlingException' :: 'Prism'' 'HandlingException' () -- '_HandlingException' :: 'Prism'' 'SomeException' () -- @ _HandlingException :: Prism' t () _HandlingException = __HandlingException._HandlingException {-# INLINE _HandlingException #-} instance AsHandlingException HandlingException where __HandlingException = id {-# INLINE __HandlingException #-} _HandlingException = trivial HandlingException {-# INLINE _HandlingException #-} instance AsHandlingException SomeException where __HandlingException = exception {-# INLINE __HandlingException #-} pattern HandlingException__ :: AsHandlingException s => HandlingException -> s pattern HandlingException__ e <- (preview __HandlingException -> Just e) where HandlingException__ e = review __HandlingException e pattern HandlingException_ :: AsHandlingException s => s pattern HandlingException_ <- (has _HandlingException -> True) where HandlingException_ = review _HandlingException () ------------------------------------------------------------------------------ -- Helper Functions ------------------------------------------------------------------------------ trivial :: t -> Iso' t () trivial t = const () `iso` const t lens-5.2.3/src/Control/0000755000000000000000000000000007346545000013062 5ustar0000000000000000lens-5.2.3/src/Control/Lens.hs0000644000000000000000000000526107346545000014323 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens -- Copyright : (C) 2012-16 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 FooBar a -- = Foo { _x :: ['Int'], _y :: a } -- | Bar { _x :: ['Int'] } -- 'makeLenses' ''FooBar -- @ -- -- This defines the following lenses: -- -- @ -- x :: 'Lens'' (FooBar a) ['Int'] -- y :: t'Traversal' (FooBar a) (FooBar b) a b -- @ -- -- You can then access the value of @_x@ with ('^.'), the value of @_y@ – -- with ('^?') or ('^?!') (since it can fail), set the values with ('.~'), -- modify them with ('%~'), and 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.At , module Control.Lens.Cons , module Control.Lens.Each , module Control.Lens.Empty , 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.Plated , module Control.Lens.Prism , module Control.Lens.Reified , module Control.Lens.Review , module Control.Lens.Setter #ifndef DISABLE_TEMPLATE_HASKELL , module Control.Lens.TH #endif , module Control.Lens.Traversal , module Control.Lens.Tuple , module Control.Lens.Type , module Control.Lens.Wrapped , module Control.Lens.Zoom ) where import Control.Lens.At import Control.Lens.Cons import Control.Lens.Each import Control.Lens.Empty 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.Plated import Control.Lens.Prism import Control.Lens.Reified import Control.Lens.Review import Control.Lens.Setter #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.Zoom lens-5.2.3/src/Control/Lens/0000755000000000000000000000000007346545000013763 5ustar0000000000000000lens-5.2.3/src/Control/Lens/At.hs0000644000000000000000000004356607346545000014701 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.At -- Copyright : (C) 2012-16 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 , iat -- * Ixed , Index , IxValue , Ixed(ix) , ixAt , iix -- * Contains , Contains(contains) , icontains ) where import Prelude () import Control.Lens.Each import Control.Lens.Internal.Prelude import Control.Lens.Traversal import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.Indexed import Control.Monad (guard) import Data.Array.IArray as Array import Data.Array.Unboxed import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB import Data.Complex import Data.Functor (($>)) import Data.Hashable import qualified Data.HashMap.Lazy as HashMap import Data.HashMap.Lazy (HashMap) import qualified Data.HashSet as HashSet import Data.HashSet (HashSet) import Data.Int import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet) import Data.Kind import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (isJust) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Sequence as Seq import Data.Sequence (Seq) import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT import Data.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 qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import Data.Word import Foreign.Storable (Storable) type family Index (s :: Type) :: Type type instance Index (e -> a) = e type instance Index IntSet = Int type instance Index (Set a) = a type instance Index (HashSet a) = a type instance Index [a] = Int type instance Index (NonEmpty a) = Int type instance Index (Seq a) = Int type instance Index (a,b) = Int type instance Index (a,b,c) = Int type instance Index (a,b,c,d) = Int type instance Index (a,b,c,d,e) = Int type instance Index (a,b,c,d,e,f) = Int type instance Index (a,b,c,d,e,f,g) = Int type instance Index (a,b,c,d,e,f,g,h) = Int type instance Index (a,b,c,d,e,f,g,h,i) = Int type instance Index (IntMap a) = Int type instance Index (Map k a) = k type instance Index (HashMap k a) = k type instance Index (Array.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 qualified Data.IntSet as IntSet -- >>> import qualified Data.Sequence as Seq -- >>> import qualified Data.Map as Map -- >>> 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 -- >>> let f' :: Int -> Expr -> Expr; f' = Debug.SimpleReflect.Vars.f' -- >>> let h :: Int -> Expr; h = Debug.SimpleReflect.Vars.h -- | -- This class provides a simple 'Lens' that lets you view (and modify) -- information about whether or not a container contains a given 'Index'. class Contains 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 -> Lens' m Bool -- | An indexed version of 'contains'. -- -- >>> IntSet.fromList [1,2,3,4] ^@. icontains 3 -- (3,True) -- -- >>> IntSet.fromList [1,2,3,4] ^@. icontains 5 -- (5,False) -- -- >>> IntSet.fromList [1,2,3,4] & icontains 3 %@~ \i x -> if odd i then not x else x -- fromList [1,2,4] -- -- >>> IntSet.fromList [1,2,3,4] & icontains 3 %@~ \i x -> if even i then not x else x -- fromList [1,2,3,4] icontains :: Contains m => Index m -> IndexedLens' (Index m) m Bool icontains i f = contains i (indexed f i) {-# INLINE icontains #-} instance Contains IntSet where #if MIN_VERSION_containers(0,6,3) contains k f = IntSet.alterF f k #else -- This is a flipped copy of the implementation of `IntSet.alterF`. Unlike a -- `Set`, we don't have to worry about expensive comparisons from descending -- multiple times into an `IntSet`. We are careful to share the results of -- insertion or deletion across multiple positions in the `Functor`. contains k f s = fmap choose (f member_) where member_ = IntSet.member k s (inserted, deleted) | member_ = (s, IntSet.delete k s) | otherwise = (IntSet.insert k s, s) choose True = inserted choose False = deleted #endif {-# INLINE contains #-} instance Ord a => Contains (Set a) where #if MIN_VERSION_containers(0,6,3) contains k f = Set.alterF f k #else contains k f s = f (Set.member k s) <&> \b -> if b then Set.insert k s else Set.delete k s #endif {-# INLINE contains #-} instance (Eq a, Hashable a) => Contains (HashSet a) where contains k f s = HashSet.fromMap <$> HashMap.alterF (fmap guard . f . isJust) k (HashSet.toMap 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 :: Type) :: Type -- | Provides a simple 'Traversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. class Ixed m where -- | -- /NB:/ Setting the value of this 'Traversal' will only set the value in -- 'at' 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 -> Traversal' m (IxValue m) default ix :: At m => Index m -> Traversal' m (IxValue m) ix = ixAt {-# INLINE ix #-} -- | An indexed version of 'ix'. -- -- >>> Seq.fromList [a,b,c,d] & iix 2 %@~ f' -- fromList [a,b,f' 2 c,d] -- -- >>> Seq.fromList [a,b,c,d] & iix 2 .@~ h -- fromList [a,b,h 2,d] -- -- >>> Seq.fromList [a,b,c,d] ^@? iix 2 -- Just (2,c) -- -- >>> Seq.fromList [] ^@? iix 2 -- Nothing iix :: Ixed m => Index m -> IndexedTraversal' (Index m) m (IxValue m) iix i f = ix i (indexed f i) {-# INLINE iix #-} -- | A definition of 'ix' for types with an 'At' instance. This is the default -- if you don't specify a definition for 'ix'. ixAt :: At m => Index m -> Traversal' m (IxValue m) ixAt i = at i . traverse {-# INLINE ixAt #-} type instance IxValue (e -> a) = a instance Eq e => Ixed (e -> a) where ix e p f = p (f e) <&> \a e' -> if e == e' then a else f e' {-# INLINE ix #-} type instance IxValue (Maybe a) = a instance Ixed (Maybe a) where ix ~() f (Just a) = Just <$> f a ix ~() _ Nothing = pure Nothing {-# INLINE ix #-} type instance IxValue [a] = a instance Ixed [a] where ix k f xs0 | k < 0 = pure xs0 | otherwise = go xs0 k where go [] _ = pure [] go (a:as) 0 = f a <&> (:as) go (a:as) i = (a:) <$> (go as $! i - 1) {-# INLINE ix #-} type instance IxValue (NonEmpty a) = a instance Ixed (NonEmpty a) where ix k f xs0 | k < 0 = pure xs0 | otherwise = go xs0 k where go (a:|as) 0 = f a <&> (:|as) go (a:|as) i = (a:|) <$> ix (i - 1) f as {-# INLINE ix #-} type instance IxValue (Identity a) = a instance Ixed (Identity a) where ix ~() f (Identity a) = Identity <$> f a {-# INLINE ix #-} type instance IxValue (Tree a) = a instance Ixed (Tree a) where ix xs0 f = go xs0 where go [] (Node a as) = f a <&> \a' -> Node a' as go (i:is) t@(Node a as) | i < 0 = pure t | otherwise = Node a <$> ix i (go is) as {-# INLINE ix #-} type instance IxValue (Seq a) = a instance Ixed (Seq a) where ix i f m | 0 <= i && i < Seq.length m = f (Seq.index m i) <&> \a -> Seq.update i a m | otherwise = pure m {-# INLINE ix #-} type instance IxValue (IntMap a) = a instance Ixed (IntMap a) where ix k f m = case IntMap.lookup k m of Just v -> f v <&> \v' -> IntMap.insert k v' m Nothing -> pure m {-# INLINE ix #-} type instance IxValue (Map k a) = a instance Ord k => Ixed (Map k a) where ix k f m = case Map.lookup k m of Just v -> f v <&> \v' -> Map.insert k v' m Nothing -> pure m {-# INLINE ix #-} type instance IxValue (HashMap k a) = a instance (Eq k, Hashable k) => Ixed (HashMap k a) where ix k f m = case HashMap.lookup k m of Just v -> f v <&> \v' -> HashMap.insert k v' m Nothing -> pure m {-# INLINE ix #-} type instance IxValue (Set k) = () instance Ord k => Ixed (Set k) where ix k f m = if Set.member k m then f () $> m else pure m {-# INLINE ix #-} type instance IxValue IntSet = () instance Ixed IntSet where ix k f m = if IntSet.member k m then f () $> m else pure m {-# INLINE ix #-} type instance IxValue (HashSet k) = () instance (Eq k, Hashable k) => Ixed (HashSet k) where ix k f m = if HashSet.member k m then f () $> m else pure m {-# INLINE ix #-} type instance IxValue (Array.Array i e) = e -- | -- @ -- arr '!' i ≡ arr 'Control.Lens.Getter.^.' 'ix' i -- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr -- @ instance Ix i => Ixed (Array.Array i e) where ix i f arr | inRange (bounds arr) i = f (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 (IArray UArray e, Ix i) => Ixed (UArray i e) where ix i f arr | inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)] | otherwise = pure arr {-# INLINE ix #-} type instance IxValue (Vector.Vector a) = a instance Ixed (Vector.Vector a) where ix i f v | 0 <= i && i < Vector.length v = f (v Vector.! i) <&> \a -> v Vector.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue (Prim.Vector a) = a instance Prim a => Ixed (Prim.Vector a) where ix i f v | 0 <= i && i < Prim.length v = f (v Prim.! i) <&> \a -> v Prim.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue (Storable.Vector a) = a instance Storable a => Ixed (Storable.Vector a) where ix i f v | 0 <= i && i < Storable.length v = f (v Storable.! i) <&> \a -> v Storable.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue (Unboxed.Vector a) = a instance Unbox a => Ixed (Unboxed.Vector a) where ix i f v | 0 <= i && i < Unboxed.length v = f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)] | otherwise = pure v {-# INLINE ix #-} type instance IxValue StrictT.Text = Char instance Ixed StrictT.Text where ix e f s | e < 0 = pure s | otherwise = case StrictT.splitAt e s of (l, mr) -> case StrictT.uncons mr of Nothing -> pure s Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyT.Text = Char instance Ixed LazyT.Text where ix e f s | e < 0 = pure s | otherwise = case LazyT.splitAt e s of (l, mr) -> case LazyT.uncons mr of Nothing -> pure s Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs) {-# INLINE ix #-} type instance IxValue StrictB.ByteString = Word8 instance Ixed StrictB.ByteString where ix e f s | e < 0 = pure s | otherwise = case StrictB.splitAt e s of (l, mr) -> case StrictB.uncons mr of Nothing -> pure s Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyB.ByteString = Word8 instance Ixed LazyB.ByteString where -- TODO: we could be lazier, returning each chunk as it is passed ix e f s | e < 0 = pure s | otherwise = case LazyB.splitAt e s of (l, mr) -> case LazyB.uncons mr of Nothing -> pure s Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs) {-# 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 Ixed m => 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 -> Lens' m (Maybe (IxValue m)) -- | Delete the value associated with a key in a 'Map'-like container -- -- @ -- 'sans' k = 'at' k .~ Nothing -- @ sans :: At m => Index m -> m -> m sans k m = m & at k .~ Nothing {-# INLINE sans #-} -- | An indexed version of 'at'. -- -- >>> Map.fromList [(1,"world")] ^@. iat 1 -- (1,Just "world") -- -- >>> iat 1 %@~ (\i x -> if odd i then Just "hello" else Nothing) $ Map.empty -- fromList [(1,"hello")] -- -- >>> iat 2 %@~ (\i x -> if odd i then Just "hello" else Nothing) $ Map.empty -- fromList [] -- iat :: At m => Index m -> IndexedLens' (Index m) m (Maybe (IxValue m)) iat i f = at i (indexed f i) {-# INLINE iat #-} instance At (Maybe a) where at ~() f = f {-# INLINE at #-} instance At (IntMap a) where #if MIN_VERSION_containers(0,5,8) at k f = IntMap.alterF f k #else at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (IntMap.delete k m)) mv Just v' -> IntMap.insert k v' m where mv = IntMap.lookup k m #endif {-# INLINE at #-} instance Ord k => At (Map k a) where #if MIN_VERSION_containers(0,5,8) at k f = Map.alterF f k #else at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (Map.delete k m)) mv Just v' -> Map.insert k v' m where mv = Map.lookup k m #endif {-# INLINE at #-} instance (Eq k, Hashable k) => At (HashMap k a) where at k f = HashMap.alterF f k {-# INLINE at #-} instance At IntSet where -- This is a gently modified copy of the implementation of `IntSet.alterF`. -- Unlike a `Set`, we don't have to worry about expensive comparisons from -- descending multiple times into an `IntSet`. We are careful to share the -- results of insertion or deletion across multiple positions in the -- `Functor`. at k f s = fmap choose (f (guard member_)) where member_ = IntSet.member k s (inserted, deleted) | member_ = (s, IntSet.delete k s) | otherwise = (IntSet.insert k s, s) choose (Just ~()) = inserted choose Nothing = deleted {-# INLINE at #-} instance Ord k => At (Set k) where #if MIN_VERSION_containers(0,6,3) at k f = Set.alterF (fmap isJust . f . guard) k #else at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (Set.delete k m)) mv Just ~() -> maybe (Set.insert k m) (const m) mv where mv = if Set.member k m then Just () else Nothing #endif {-# INLINE at #-} instance (Eq k, Hashable k) => At (HashSet k) where at k f s = HashSet.fromMap <$> HashMap.alterF f k (HashSet.toMap s) {-# INLINE at #-} -- | @'ix' :: 'Int' -> 'Traversal'' (a,a) a@ type instance IxValue (a,a2) = a instance (a~a2) => Ixed (a,a2) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a) a@ type instance IxValue (a,a2,a3) = a instance (a~a2, a~a3) => Ixed (a,a2,a3) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a) a@ type instance IxValue (a,a2,a3,a4) = a instance (a~a2, a~a3, a~a4) => Ixed (a,a2,a3,a4) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5) = a instance (a~a2, a~a3, a~a4, a~a5) => Ixed (a,a2,a3,a4,a5) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6) => Ixed (a,a2,a3,a4,a5,a6) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6,a7) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7) => Ixed (a,a2,a3,a4,a5,a6,a7) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8) => Ixed (a,a2,a3,a4,a5,a6,a7,a8) where ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8,a9) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9) => Ixed (a,a2,a3,a4,a5,a6,a7,a8,a9) where ix p = elementOf each p lens-5.2.3/src/Control/Lens/Combinators.hs0000644000000000000000000000401107346545000016573 0ustar0000000000000000{-# Language CPP #-} -------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Combinators -- Copyright : (C) 2013-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This lets the subset of users who vociferously disagree about the full -- scope and set of operators that should be exported from lens to not have -- to look at any operator with which they disagree. -- -- > import Control.Lens.Combinators -------------------------------------------------------------------------------- module Control.Lens.Combinators ( module Control.Lens ) where import Control.Lens hiding ( (<|) , (|>) , (^..) , (^?) , (^?!) , (^@..) , (^@?) , (^@?!) , (^.) , (^@.) , (<.) , (.>) , (<.>) , (%%~) , (%%=) , (&) , (&~) , (<&>) , (??) , (<%~) , (<+~) , (<-~) , (<*~) , (~) , (<%=) , (<+=) , (<-=) , (<*=) , (=) , (<<~) , (<<>~) , (<<>=) , (<%@~) , (<<%@~) , (%%@~) , (%%@=) , (<%@=) , (<<%@=) , (.@=) , (.@~) , (^#) , (#~) , (#%~) , (#%%~) , (#=) , (#%=) , (<#%~) , (<#%=) , (#%%=) , (<#~) , (<#=) , (...) , (#) , (%~) , (.~) , (?~) , (<.~) , (~) , (<>=) , (%@~) , (%@=) , (:>) , (:<) ) lens-5.2.3/src/Control/Lens/Cons.hs0000644000000000000000000003404507346545000015227 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Cons -- Copyright : (C) 2012-16 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 , pattern (:<) -- * Snoc , Snoc(..) , (|>) , snoc , unsnoc , _init, _last , pattern (:>) ) where import Control.Lens.Equality (simply) import Control.Lens.Fold 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.Coerce import Data.Monoid import qualified Data.Sequence as Seq import Data.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), viewl, viewr) 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 import Control.Applicative (ZipList(..)) import Prelude -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import qualified Data.Sequence as Seq -- >>> import qualified Data.Vector as Vector -- >>> import qualified Data.Text.Lazy as LazyT -- >>> 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` pattern (:<) :: Cons b b a a => a -> b -> b pattern (:<) a s <- (preview _Cons -> Just (a,s)) where (:<) a s = _Cons # (a,s) infixr 5 :< infixl 5 :> pattern (:>) :: Snoc a a b b => a -> b -> a pattern (:>) s a <- (preview _Snoc -> Just (s,a)) where (:>) a s = _Snoc # (a,s) ------------------------------------------------------------------------------ -- Cons ------------------------------------------------------------------------------ -- | This class provides a way to attach or detach elements on the left -- side of a structure in a flexible manner. class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | -- -- @ -- '_Cons' :: 'Prism' [a] [b] (a, [a]) (b, [b]) -- '_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') -- @ _Cons :: Prism s t (a,s) (b,t) instance Cons [a] [b] a b where _Cons = prism (uncurry (:)) $ \ aas -> case aas of (a:as) -> Right (a, as) [] -> Left [] {-# INLINE _Cons #-} instance Cons (ZipList a) (ZipList b) a b where _Cons = withPrism listCons $ \listReview listPreview -> prism (coerce listReview) (coerce listPreview) where listCons :: Prism [a] [b] (a, [a]) (b, [b]) listCons = _Cons {-# INLINE _Cons #-} instance Cons (Seq a) (Seq b) a b where _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of a Seq.:< as -> Right (a, as) EmptyL -> Left mempty {-# INLINE _Cons #-} instance Cons StrictB.ByteString StrictB.ByteString Word8 Word8 where _Cons = prism' (uncurry StrictB.cons) StrictB.uncons {-# INLINE _Cons #-} instance Cons LazyB.ByteString LazyB.ByteString Word8 Word8 where _Cons = prism' (uncurry LazyB.cons) LazyB.uncons {-# INLINE _Cons #-} instance Cons StrictT.Text StrictT.Text Char Char where _Cons = prism' (uncurry StrictT.cons) StrictT.uncons {-# INLINE _Cons #-} instance Cons LazyT.Text LazyT.Text Char Char where _Cons = prism' (uncurry LazyT.cons) LazyT.uncons {-# INLINE _Cons #-} instance Cons (Vector a) (Vector b) a b where _Cons = prism (uncurry Vector.cons) $ \v -> if Vector.null v then Left Vector.empty else Right (Vector.unsafeHead v, Vector.unsafeTail v) {-# INLINE _Cons #-} instance (Prim a, Prim b) => Cons (Prim.Vector a) (Prim.Vector b) a b where _Cons = prism (uncurry Prim.cons) $ \v -> if Prim.null v then Left Prim.empty else Right (Prim.unsafeHead v, Prim.unsafeTail v) {-# INLINE _Cons #-} instance (Storable a, Storable b) => Cons (Storable.Vector a) (Storable.Vector b) a b where _Cons = prism (uncurry Storable.cons) $ \v -> if Storable.null v then Left Storable.empty else Right (Storable.unsafeHead v, Storable.unsafeTail v) {-# INLINE _Cons #-} instance (Unbox a, Unbox b) => Cons (Unbox.Vector a) (Unbox.Vector b) a b where _Cons = prism (uncurry Unbox.cons) $ \v -> if Unbox.null v then Left Unbox.empty else Right (Unbox.unsafeHead v, Unbox.unsafeTail v) {-# INLINE _Cons #-} -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'. -- -- >>> a <| [] -- [a] -- -- >>> a <| [b, c] -- [a,b,c] -- -- >>> a <| Seq.fromList [] -- fromList [a] -- -- >>> a <| Seq.fromList [b, c] -- fromList [a,b,c] (<|) :: Cons s s a a => a -> s -> s (<|) = curry (simply review _Cons) {-# INLINE (<|) #-} -- | 'cons' an element onto a container. -- -- >>> cons a [] -- [a] -- -- >>> cons a [b, c] -- [a,b,c] -- -- >>> cons a (Seq.fromList []) -- fromList [a] -- -- >>> cons a (Seq.fromList [b, c]) -- fromList [a,b,c] cons :: Cons s s a a => a -> s -> s cons = curry (simply review _Cons) {-# INLINE cons #-} -- | Attempt to extract the left-most element from a container, and a version of the container without that element. -- -- >>> uncons [] -- Nothing -- -- >>> uncons [a, b, c] -- Just (a,[b,c]) uncons :: Cons s s a a => s -> Maybe (a, s) uncons = simply preview _Cons {-# INLINE uncons #-} -- | 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 s s a a => Traversal' 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 s s a a => Traversal' 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 Snoc s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | -- -- @ -- '_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') -- @ _Snoc :: Prism s t (s,a) (t,b) instance Snoc [a] [b] a b where _Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas then Left [] else Right (Prelude.init aas, Prelude.last aas) {-# INLINE _Snoc #-} instance Snoc (ZipList a) (ZipList b) a b where _Snoc = withPrism listSnoc $ \listReview listPreview -> prism (coerce listReview) (coerce listPreview) where listSnoc :: Prism [a] [b] ([a], a) ([b], b) listSnoc = _Snoc {-# INLINE _Snoc #-} instance Snoc (Seq a) (Seq b) a b where _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of as Seq.:> a -> Right (as, a) EmptyR -> Left mempty {-# INLINE _Snoc #-} instance Snoc (Vector a) (Vector b) a b where _Snoc = prism (uncurry Vector.snoc) $ \v -> if Vector.null v then Left Vector.empty else Right (Vector.unsafeInit v, Vector.unsafeLast v) {-# INLINE _Snoc #-} instance (Prim a, Prim b) => Snoc (Prim.Vector a) (Prim.Vector b) a b where _Snoc = prism (uncurry Prim.snoc) $ \v -> if Prim.null v then Left Prim.empty else Right (Prim.unsafeInit v, Prim.unsafeLast v) {-# INLINE _Snoc #-} instance (Storable a, Storable b) => Snoc (Storable.Vector a) (Storable.Vector b) a b where _Snoc = prism (uncurry Storable.snoc) $ \v -> if Storable.null v then Left Storable.empty else Right (Storable.unsafeInit v, Storable.unsafeLast v) {-# INLINE _Snoc #-} instance (Unbox a, Unbox b) => Snoc (Unbox.Vector a) (Unbox.Vector b) a b where _Snoc = prism (uncurry Unbox.snoc) $ \v -> if Unbox.null v then Left Unbox.empty else Right (Unbox.unsafeInit v, Unbox.unsafeLast v) {-# INLINE _Snoc #-} instance Snoc StrictB.ByteString StrictB.ByteString Word8 Word8 where _Snoc = prism (uncurry StrictB.snoc) $ \v -> if StrictB.null v then Left StrictB.empty else Right (StrictB.init v, StrictB.last v) {-# INLINE _Snoc #-} instance Snoc LazyB.ByteString LazyB.ByteString Word8 Word8 where _Snoc = prism (uncurry LazyB.snoc) $ \v -> if LazyB.null v then Left LazyB.empty else Right (LazyB.init v, LazyB.last v) {-# INLINE _Snoc #-} instance Snoc StrictT.Text StrictT.Text Char Char where _Snoc = prism (uncurry StrictT.snoc) $ \v -> if StrictT.null v then Left StrictT.empty else Right (StrictT.init v, StrictT.last v) {-# INLINE _Snoc #-} instance Snoc LazyT.Text LazyT.Text Char Char where _Snoc = prism (uncurry LazyT.snoc) $ \v -> if LazyT.null v then Left LazyT.empty else Right (LazyT.init v, LazyT.last v) {-# 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 s s a a => Traversal' 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') == Vector.fromList "abcdQ" -- True -- -- @ -- '_last' :: 'Traversal'' [a] a -- '_last' :: 'Traversal'' ('Seq' a) a -- '_last' :: 'Traversal'' ('Vector' a) a -- @ _last :: Snoc s s a a => Traversal' s a _last = _Snoc._2 {-# INLINE _last #-} -- | 'snoc' an element onto the end of a container. -- -- This is an infix alias for 'snoc'. -- -- >>> Seq.fromList [] |> a -- fromList [a] -- -- >>> Seq.fromList [b, c] |> a -- fromList [b,c,a] -- -- >>> LazyT.pack "hello" |> '!' -- "hello!" (|>) :: Snoc s s a a => s -> a -> s (|>) = curry (simply review _Snoc) {-# INLINE (|>) #-} -- | 'snoc' an element onto the end of a container. -- -- >>> snoc (Seq.fromList []) a -- fromList [a] -- -- >>> snoc (Seq.fromList [b, c]) a -- fromList [b,c,a] -- -- >>> snoc (LazyT.pack "hello") '!' -- "hello!" snoc :: Snoc s s a a => s -> a -> s snoc = curry (simply review _Snoc) {-# INLINE snoc #-} -- | Attempt to extract the right-most element from a container, and a version of the container without that element. -- -- >>> unsnoc (LazyT.pack "hello!") -- Just ("hello",'!') -- -- >>> unsnoc (LazyT.pack "") -- Nothing -- -- >>> unsnoc (Seq.fromList [b,c,a]) -- Just (fromList [b,c],a) -- -- >>> unsnoc (Seq.fromList []) -- Nothing unsnoc :: Snoc s s a a => s -> Maybe (s, a) unsnoc = simply preview _Snoc {-# INLINE unsnoc #-} lens-5.2.3/src/Control/Lens/Each.hs0000644000000000000000000002322507346545000015163 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Each -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.Each ( -- * Each Each(..) ) where import Prelude () import Control.Lens.Traversal import Control.Lens.Internal.ByteString import Control.Lens.Internal.Prelude import Data.Array.Unboxed as Unboxed import Data.Array.IArray as IArray import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB import Data.Complex import Data.HashMap.Lazy (HashMap) import Data.IntMap (IntMap) import Data.Map (Map) import Data.Sequence (Seq) import Data.Text.Lens (text) import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT import Data.Tree as Tree import Data.Vector.Generic.Lens (vectorTraverse) 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 import qualified Data.Strict as S import Data.These (These (..)) -- $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" -- -- >>> ("hello","world") & each.each %~ Char.toUpper -- ("HELLO","WORLD") class Each s t a b | s -> a, t -> b, s b -> t, t a -> s where each :: Traversal s t a b default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b each = traverse {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a) (b,b) a b@ instance (a~a', b~b') => Each (a,a') (b,b') a b where each f ~(a,b) = (,) <$> f a <*> f b {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a) (b,b,b) a b@ instance (a~a2, a~a3, b~b2, b~b3) => Each (a,a2,a3) (b,b2,b3) a b where each f ~(a,b,c) = (,,) <$> f a <*> f b <*> f c {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a,a) (b,b,b,b) a b@ instance (a~a2, a~a3, a~a4, b~b2, b~b3, b~b4) => Each (a,a2,a3,a4) (b,b2,b3,b4) a b where each f ~(a,b,c,d) = (,,,) <$> f a <*> f b <*> f c <*> f d {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a,a,a) (b,b,b,b,b) a b@ instance (a~a2, a~a3, a~a4, a~a5, b~b2, b~b3, b~b4, b~b5) => Each (a,a2,a3,a4,a5) (b,b2,b3,b4,b5) a b where each f ~(a,b,c,d,e) = (,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a,a,a,a) (b,b,b,b,b,b) a b@ instance (a~a2, a~a3, a~a4, a~a5, a~a6, b~b2, b~b3, b~b4, b~b5, b~b6) => Each (a,a2,a3,a4,a5,a6) (b,b2,b3,b4,b5,b6) a b where each f ~(a,b,c,d,e,g) = (,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a,a,a,a,a) (b,b,b,b,b,b,b) a b@ instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7) => Each (a,a2,a3,a4,a5,a6,a7) (b,b2,b3,b4,b5,b6,b7) a b where each f ~(a,b,c,d,e,g,h) = (,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b) a b@ instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8) => Each (a,a2,a3,a4,a5,a6,a7,a8) (b,b2,b3,b4,b5,b6,b7,b8) a b where each f ~(a,b,c,d,e,g,h,i) = (,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i {-# INLINE each #-} -- | @'each' :: 'Traversal' (a,a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b,b) a b@ instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8, b~b9) => Each (a,a2,a3,a4,a5,a6,a7,a8,a9) (b,b2,b3,b4,b5,b6,b7,b8,b9) a b where each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i <*> f j {-# INLINE each #-} -- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'Traversal' ('Complex' a) ('Complex' b) a b@ instance Each (Complex a) (Complex b) a b where each f (a :+ b) = (:+) <$> f a <*> f b {-# INLINE each #-} -- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@ instance (c ~ d) => Each (Map c a) (Map d b) a b where each = traversed {-# INLINE each #-} -- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@ instance Each (IntMap a) (IntMap b) a b where each = traversed {-# INLINE each #-} -- | @'each' :: 'Traversal' ('HashMap' c a) ('HashMap' c b) a b@ instance (c ~ d) => Each (HashMap c a) (HashMap d b) a b where each = traversed {-# INLINE each #-} -- | @'each' :: 'Traversal' [a] [b] a b@ instance Each [a] [b] a b where each = traversed {-# INLINE each #-} -- | @'each' :: 'Traversal' (NonEmpty a) (NonEmpty b) a b@ instance Each (NonEmpty a) (NonEmpty b) a b -- | @'each' :: 'Traversal' ('Identity' a) ('Identity' b) a b@ instance Each (Identity a) (Identity b) a b -- | @'each' :: 'Traversal' ('Maybe' a) ('Maybe' b) a b@ instance Each (Maybe a) (Maybe b) a b -- | @'each' :: 'Traversal' ('Either' a a) ('Either' b b) a b@ -- -- @since 4.18 instance (a~a', b~b') => Each (Either a a') (Either b b') a b where each f (Left a) = Left <$> f a each f (Right a ) = Right <$> f a {-# INLINE each #-} -- | @'each' :: 'Traversal' ('Seq' a) ('Seq' b) a b@ instance Each (Seq a) (Seq b) a b where each = traversed {-# INLINE each #-} -- | @'each' :: 'Traversal' ('Tree' a) ('Tree' b) a b@ instance Each (Tree a) (Tree b) a b -- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@ instance Each (Vector.Vector a) (Vector.Vector b) a b where each = vectorTraverse {-# INLINE each #-} -- | @'each' :: ('Prim' a, 'Prim' b) => 'Traversal' ('Prim.Vector' a) ('Prim.Vector' b) a b@ instance (Prim a, Prim b) => Each (Prim.Vector a) (Prim.Vector b) a b where each = vectorTraverse {-# INLINE each #-} -- | @'each' :: ('Storable' a, 'Storable' b) => 'Traversal' ('Storable.Vector' a) ('Storable.Vector' b) a b@ instance (Storable a, Storable b) => Each (Storable.Vector a) (Storable.Vector b) a b where each = vectorTraverse {-# INLINE each #-} -- | @'each' :: ('Unbox' a, 'Unbox' b) => 'Traversal' ('Unboxed.Vector' a) ('Unboxed.Vector' b) a b@ instance (Unbox a, Unbox b) => Each (Unboxed.Vector a) (Unboxed.Vector b) a b where each = vectorTraverse {-# INLINE each #-} -- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@ instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where each = text {-# INLINE each #-} -- | @'each' :: 'Traversal' 'LazyT.Text' 'LazyT.Text' 'Char' 'Char'@ instance (a ~ Char, b ~ Char) => Each LazyT.Text LazyT.Text a b where each = text {-# INLINE each #-} -- | @'each' :: 'Traversal' 'StrictB.ByteString' 'StrictB.ByteString' 'Word8' 'Word8'@ instance (a ~ Word8, b ~ Word8) => Each StrictB.ByteString StrictB.ByteString a b where each = traversedStrictTree {-# INLINE each #-} -- | @'each' :: 'Traversal' 'LazyB.ByteString' 'LazyB.ByteString' 'Word8' 'Word8'@ instance (a ~ Word8, b ~ Word8) => Each LazyB.ByteString LazyB.ByteString a b where each = traversedLazy {-# INLINE each #-} -- | @'each' :: 'Ix' i => 'Traversal' ('Array' i a) ('Array' i b) a b@ instance (Ix i, i ~ j) => Each (Array i a) (Array j b) a b where each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr) {-# INLINE each #-} -- | @'each' :: ('Ix' i, 'IArray' 'UArray' a, 'IArray' 'UArray' b) => 'Traversal' ('Array' i a) ('Array' i b) a b@ instance (Ix i, IArray UArray a, IArray UArray b, i ~ j) => Each (UArray i a) (UArray j b) a b where each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr) {-# INLINE each #-} ------------------------------------------------------------------------------- -- strict ------------------------------------------------------------------------------- -- | @since 4.20 instance (a ~ a', b ~ b') => Each (S.Either a a') (S.Either b b') a b where each f (S.Left x) = S.Left <$> f x each f (S.Right x) = S.Right <$> f x {-# INLINE each #-} -- | @since 4.20 instance (a~a', b~b') => Each (S.Pair a a') (S.Pair b b') a b where each f (a S.:!: b) = (S.:!:) <$> f a <*> f b {-# INLINE each #-} -- | @since 4.20 instance Each (S.Maybe a) (S.Maybe b) a b -- | @since 4.20 instance (a ~ a', b ~ b') => Each (S.These a a') (S.These b b') a b where each f (S.This a) = S.This <$> f a each f (S.That b) = S.That <$> f b each f (S.These a b) = S.These <$> f a <*> f b ------------------------------------------------------------------------------- -- these ------------------------------------------------------------------------------- -- | @since 4.20 instance (a ~ a', b ~ b') => Each (These a a') (These b b') a b where each f (This a) = This <$> f a each f (That b) = That <$> f b each f (These a b) = These <$> f a <*> f b lens-5.2.3/src/Control/Lens/Empty.hs0000644000000000000000000001205407346545000015417 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Empty -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ------------------------------------------------------------------------------- module Control.Lens.Empty ( AsEmpty(..) , pattern Empty ) where import Prelude () import Control.Lens.Iso import Control.Lens.Fold import Control.Lens.Prism import Control.Lens.Internal.Prelude as Prelude import Control.Lens.Review import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB import qualified Data.HashMap.Lazy as HashMap import Data.HashMap.Lazy (HashMap) import qualified Data.HashSet as HashSet import Data.HashSet (HashSet) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet) import Data.Monoid import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT import qualified Data.Vector as Vector import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Storable as Storable import Foreign.Storable (Storable) #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) import GHC.Event #endif -- $setup -- >>> import Control.Lens class AsEmpty a where -- | -- -- >>> isn't _Empty [1,2,3] -- True _Empty :: Prism' a () default _Empty :: (Monoid a, Eq a) => Prism' a () _Empty = only mempty {-# INLINE _Empty #-} pattern Empty :: AsEmpty s => s pattern Empty <- (has _Empty -> True) where Empty = review _Empty () {- Default Monoid instances -} instance AsEmpty Ordering instance AsEmpty () instance AsEmpty Any instance AsEmpty All #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) instance AsEmpty Event #endif instance (Eq a, Num a) => AsEmpty (Product a) instance (Eq a, Num a) => AsEmpty (Sum a) instance AsEmpty (Maybe a) where _Empty = _Nothing {-# INLINE _Empty #-} instance AsEmpty (Last a) where _Empty = nearly (Last Nothing) (isNothing .# getLast) {-# INLINE _Empty #-} instance AsEmpty (First a) where _Empty = nearly (First Nothing) (isNothing .# getFirst) {-# INLINE _Empty #-} instance AsEmpty a => AsEmpty (Dual a) where _Empty = iso getDual Dual . _Empty {-# INLINE _Empty #-} instance (AsEmpty a, AsEmpty b) => AsEmpty (a,b) where _Empty = prism' (\() -> (_Empty # (), _Empty # ())) $ \(s,s') -> case _Empty Left s of Left () -> case _Empty Left s' of Left () -> Just () _ -> Nothing _ -> Nothing {-# INLINE _Empty #-} instance (AsEmpty a, AsEmpty b, AsEmpty c) => AsEmpty (a,b,c) where _Empty = prism' (\() -> (_Empty # (), _Empty # (), _Empty # ())) $ \(s,s',s'') -> case _Empty Left s of Left () -> case _Empty Left s' of Left () -> case _Empty Left s'' of Left () -> Just () Right _ -> Nothing Right _ -> Nothing Right _ -> Nothing {-# INLINE _Empty #-} instance AsEmpty [a] where _Empty = nearly [] Prelude.null {-# INLINE _Empty #-} instance AsEmpty (ZipList a) where _Empty = nearly (ZipList []) (Prelude.null . getZipList) {-# INLINE _Empty #-} instance AsEmpty (Map k a) where _Empty = nearly Map.empty Map.null {-# INLINE _Empty #-} instance AsEmpty (HashMap k a) where _Empty = nearly HashMap.empty HashMap.null {-# INLINE _Empty #-} instance AsEmpty (IntMap a) where _Empty = nearly IntMap.empty IntMap.null {-# INLINE _Empty #-} instance AsEmpty (Set a) where _Empty = nearly Set.empty Set.null {-# INLINE _Empty #-} instance AsEmpty (HashSet a) where _Empty = nearly HashSet.empty HashSet.null {-# INLINE _Empty #-} instance AsEmpty IntSet where _Empty = nearly IntSet.empty IntSet.null {-# INLINE _Empty #-} instance AsEmpty (Vector.Vector a) where _Empty = nearly Vector.empty Vector.null {-# INLINE _Empty #-} instance Unbox a => AsEmpty (Unboxed.Vector a) where _Empty = nearly Unboxed.empty Unboxed.null {-# INLINE _Empty #-} instance Storable a => AsEmpty (Storable.Vector a) where _Empty = nearly Storable.empty Storable.null {-# INLINE _Empty #-} instance AsEmpty (Seq.Seq a) where _Empty = nearly Seq.empty Seq.null {-# INLINE _Empty #-} instance AsEmpty StrictB.ByteString where _Empty = nearly StrictB.empty StrictB.null {-# INLINE _Empty #-} instance AsEmpty LazyB.ByteString where _Empty = nearly LazyB.empty LazyB.null {-# INLINE _Empty #-} instance AsEmpty StrictT.Text where _Empty = nearly StrictT.empty StrictT.null {-# INLINE _Empty #-} instance AsEmpty LazyT.Text where _Empty = nearly LazyT.empty LazyT.null {-# INLINE _Empty #-} lens-5.2.3/src/Control/Lens/Equality.hs0000644000000000000000000001153007346545000016114 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE PolyKinds #-} #else {-# LANGUAGE TypeInType #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Equality -- Copyright : (C) 2012-16 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 -- * The Trivial Equality , simple -- * 'Iso'-like functions , equality , equality' , withEquality , underEquality , overEquality , fromLeibniz , fromLeibniz' , cloneEquality -- * Implementation Details , Identical(..) ) where import Control.Lens.Type import Data.Proxy (Proxy) import Data.Type.Equality ((:~:)(..)) import GHC.Exts (TYPE) import Data.Kind (Type) -- $setup -- >>> import Control.Lens #include "lens-common.h" ----------------------------------------------------------------------------- -- 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 (Proxy b) a (Proxy b) -> Identical a (Proxy b) s (Proxy 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 :: forall s t a b rep (r :: TYPE rep). 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 :: forall k1 k2 (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> Type) . 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 :: forall p f s a rep (r :: TYPE rep). (Optic' p f s a -> r) -> Optic' p f s a -> r simply = id {-# INLINE simply #-} -- | 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 :: Equality' a a simple = id {-# INLINE simple #-} cloneEquality :: AnEquality s t a b -> Equality s t a b cloneEquality an = substEq an id {-# INLINE cloneEquality #-} -- | Construct an 'Equality' from explicit equality evidence. equality :: s :~: a -> b :~: t -> Equality s t a b equality Refl Refl = id {-# INLINE equality #-} -- | A 'Simple' version of 'equality' equality' :: a :~: b -> Equality' a b equality' Refl = id {-# INLINE equality' #-} -- | Recover a "profunctor lens" form of equality. Reverses 'fromLeibniz'. overEquality :: AnEquality s t a b -> p a b -> p s t overEquality an = substEq an id {-# INLINE overEquality #-} -- | The opposite of working 'overEquality' is working 'underEquality'. underEquality :: AnEquality s t a b -> p t s -> p b a underEquality an = substEq an id {-# INLINE underEquality #-} -- | Convert a "profunctor lens" form of equality to an equality. Reverses -- 'overEquality'. -- -- The type should be understood as -- -- @fromLeibniz :: (forall p. p a b -> p s t) -> Equality s t a b@ fromLeibniz :: (Identical a b a b -> Identical a b s t) -> Equality s t a b fromLeibniz f = case f Identical of Identical -> id {-# INLINE fromLeibniz #-} -- | Convert Leibniz equality to equality. Reverses 'mapEq' in 'Simple' cases. -- -- The type should be understood as -- -- @fromLeibniz' :: (forall f. f s -> f a) -> Equality' s a@ fromLeibniz' :: (s :~: s -> s :~: a) -> Equality' s a fromLeibniz' f = case f Refl of Refl -> id {-# INLINE fromLeibniz' #-} -- | A version of 'substEq' that provides explicit, rather than implicit, -- equality evidence. withEquality :: forall s t a b rep (r :: TYPE rep). AnEquality s t a b -> (s :~: a -> b :~: t -> r) -> r withEquality an = substEq an (\f -> f Refl Refl) {-# INLINE withEquality #-} lens-5.2.3/src/Control/Lens/Extras.hs0000644000000000000000000000150107346545000015562 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A few extra names that didn't make it into Control.Lens. -- ---------------------------------------------------------------------------- module Control.Lens.Extras ( is , module Data.Data.Lens ) where import Control.Lens import Data.Data.Lens -- $setup -- >>> import Control.Lens -- >>> import Numeric.Lens (hex) -- | Check to see if this t'Prism' matches. -- -- >>> is _Left (Right 12) -- False -- -- >>> is hex "3f79" -- True is :: APrism s t a b -> s -> Bool is k = not . isn't k {-# INLINE is #-} lens-5.2.3/src/Control/Lens/Fold.hs0000644000000000000000000030657007346545000015216 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Trustworthy #-} #include "lens-common.h" {-# OPTIONS_GHC -Wno-orphans #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold -- Copyright : (C) 2012-16 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 'Const' 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, ifolding , foldring, ifoldring , folded , folded64 , unfolded , iterated , filtered , filteredBy , backwards , repeated , replicated , cycled , takingWhile , droppingWhile , worded, lined -- ** Folding , foldMapOf, foldOf , foldrOf, foldlOf , toListOf, toNonEmptyOf , altOf , anyOf, allOf, noneOf , andOf, orOf , productOf, sumOf , traverseOf_, forOf_, sequenceAOf_ , traverse1Of_, for1Of_, sequence1Of_ , mapMOf_, forMOf_, sequenceOf_ , asumOf, msumOf , concatMapOf, concatOf , elemOf, notElemOf , lengthOf , nullOf, notNullOf , firstOf, first1Of, lastOf, last1Of , maximumOf, maximum1Of, minimumOf, minimum1Of , maximumByOf, minimumByOf , findOf , findMOf , foldrOf', foldlOf' , foldr1Of, foldl1Of , foldr1Of', foldl1Of' , foldrMOf, foldlMOf , lookupOf -- * Indexed Folds , (^@..) , (^@?) , (^@?!) -- ** Indexed Folding , ifoldMapOf , ifoldrOf , ifoldlOf , ianyOf , iallOf , inoneOf , itraverseOf_ , iforOf_ , imapMOf_ , iforMOf_ , iconcatMapOf , ifindOf , ifindMOf , ifoldrOf' , ifoldlOf' , ifoldrMOf , ifoldlMOf , itoListOf , elemIndexOf , elemIndicesOf , findIndexOf , findIndicesOf -- ** Building Indexed Folds , ifiltered , itakingWhile , idroppingWhile -- * Internal types , Leftmost , Rightmost , Traversed , Sequenced -- * Fold with Reified Monoid , foldBy , foldByOf , foldMapBy , foldMapByOf ) where import Prelude () 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.Internal.Prelude import Control.Lens.Type import Control.Monad as Monad import Control.Monad.Reader import Control.Monad.State import Data.CallStack import Data.Functor.Apply hiding ((<.)) import Data.Int (Int64) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Monoid (First (..), All (..), Alt (..), Any (..)) import Data.Reflection import qualified Data.Semigroup as Semi -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Lens.Extras (is) -- >>> import Data.Function -- >>> import Data.List.Lens -- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> 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 Data.Monoid (Sum (..)) -- >>> import System.Timeout (timeout) -- >>> import qualified Data.Map as Map -- >>> 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 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 reverse -- [4,3,2,1] folding :: Foldable f => (s -> f a) -> Fold s a folding sfa agb = phantom . traverse_ agb . sfa {-# INLINE folding #-} ifolding :: (Foldable f, Indexable i p, Contravariant g, Applicative g) => (s -> f (i, a)) -> Over p g s t a b ifolding sfa f = phantom . traverse_ (phantom . uncurry (indexed f)) . sfa {-# INLINE ifolding #-} -- | Obtain a 'Fold' by lifting 'foldr' like function. -- -- >>> [1,2,3,4]^..foldring foldr -- [1,2,3,4] foldring :: (Contravariant f, Applicative f) => ((a -> f a -> f a) -> f a -> s -> f a) -> LensLike f s t a b foldring fr f = phantom . fr (\a fa -> f a *> fa) noEffect {-# INLINE foldring #-} -- | Obtain 'FoldWithIndex' by lifting 'ifoldr' like function. ifoldring :: (Indexable i p, Contravariant f, Applicative f) => ((i -> a -> f a -> f a) -> f a -> s -> f a) -> Over p f s t a b ifoldring ifr f = phantom . ifr (\i a fa -> indexed f i a *> fa) noEffect {-# INLINE ifoldring #-} -- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position. -- -- >>> Just 3^..folded -- [3] -- -- >>> Nothing^..folded -- [] -- -- >>> [(1,2),(3,4)]^..folded.both -- [1,2,3,4] folded :: Foldable f => IndexedFold Int (f a) a folded = conjoined (foldring foldr) (ifoldring ifoldr) {-# INLINE folded #-} ifoldr :: Foldable f => (Int -> a -> b -> b) -> b -> f a -> b ifoldr f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldr #-} -- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position. folded64 :: Foldable f => IndexedFold Int64 (f a) a folded64 = conjoined (foldring foldr) (ifoldring ifoldr64) {-# INLINE folded64 #-} ifoldr64 :: Foldable f => (Int64 -> a -> b -> b) -> b -> f a -> b ifoldr64 f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldr64 #-} -- | Form a 'Fold1' 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' :: 'Fold1' a a -- @ repeated :: Apply f => LensLike' f 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 non-empty 'Fold' into a 'Fold1' that loops over its elements over and over. -- -- >>> timingOut $ [1,2,3]^..taking 7 (cycled traverse) -- [1,2,3,1,2,3,1] -- -- @ -- 'cycled' :: 'Fold1' s a -> 'Fold1' s a -- @ cycled :: Apply f => LensLike f s t a b -> LensLike f s t a b cycled l f a = as where as = l f a .> as {-# INLINE cycled #-} -- | Build a 'Fold' that unfolds its values from a seed. -- -- @ -- '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 = go where go b = case f b of Just (a, b') -> g a *> go b' Nothing -> noEffect {-# INLINE unfolded #-} -- | @x '^.' 'iterated' f@ returns an infinite 'Fold1' of repeated applications of @f@ to @x@. -- -- @ -- 'toListOf' ('iterated' f) a ≡ 'iterate' f a -- @ -- -- @ -- 'iterated' :: (a -> a) -> 'Fold1' a a -- @ iterated :: Apply f => (a -> a) -> LensLike' f a a iterated f g = go 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 fails 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) -> Optic' 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 potentially empty 'IndexedTraversal' by taking the first element from another, -- potentially empty `Fold` and using it as an index. -- -- The resulting optic can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). -- -- >>> [(Just 2, 3), (Nothing, 4)] & mapped . filteredBy (_1 . _Just) <. _2 %@~ (*) :: [(Maybe Int, Int)] -- [(Just 2,6),(Nothing,4)] -- -- @ -- 'filteredBy' :: 'Fold' a i -> 'IndexedTraversal'' i a a -- @ -- -- Note: As with 'filtered', this is /not/ a legal 'IndexedTraversal', unless you are very careful not to invalidate the predicate on the target! filteredBy :: (Indexable i p, Applicative f) => Getting (First i) a i -> p a (f a) -> a -> f a filteredBy p f val = case val ^? p of Nothing -> pure val Just witness -> indexed f witness val -- | 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') -> '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 -- @ -- -- /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 (cosieve 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') -> '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 -- @ -- -- 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 to the first target also does not pass the predicate! Otherwise subsequent traversals -- will visit fewer elements and 'Traversal' fusion is not sound. -- -- So for any traversal @t@ and predicate @p@, @`droppingWhile` p t@ may not be lawful, but -- @(`Control.Lens.Traversal.dropping` 1 . `droppingWhile` p) t@ is. For example: -- -- >>> let l :: Traversal' [Int] Int; l = droppingWhile (<= 1) traverse -- >>> let l' :: Traversal' [Int] Int; l' = dropping 1 l -- -- @l@ is not a lawful setter because @`Control.Lens.Setter.over` l f . -- `Control.Lens.Setter.over` l g ≢ `Control.Lens.Setter.over` l (f . g)@: -- -- >>> [1,2,3] & l .~ 0 & l .~ 4 -- [1,0,0] -- >>> [1,2,3] & l .~ 4 -- [1,4,4] -- -- @l'@ on the other hand behaves lawfully: -- -- >>> [1,2,3] & l' .~ 0 & l' .~ 4 -- [1,2,4] -- >>> [1,2,3] & l' .~ 4 -- [1,2,4] droppingWhile :: (Conjoined p, Profunctor q, Applicative f) => (a -> Bool) -> Optical p q (Compose (State Bool) f) s t a a -> Optical p q f s t a a droppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where g = cotabulate $ \wa -> Compose $ state $ \b -> let a = extract wa b' = b && p a in (if b' then pure a else cosieve f wa, b') {-# INLINE droppingWhile #-} -- | A 'Fold' over the individual 'words' of a 'String'. -- -- @ -- 'worded' :: 'Fold' 'String' 'String' -- 'worded' :: 'Traversal'' 'String' 'String' -- @ -- -- @ -- 'worded' :: 'IndexedFold' 'Int' 'String' 'String' -- 'worded' :: 'IndexedTraversal'' 'Int' 'String' 'String' -- @ -- -- Note: This function type-checks as a 'Traversal' but it doesn't satisfy the laws. It's only valid to use it -- when you don't insert any whitespace characters while traversing, and if your original 'String' contains only -- isolated space characters (and no other characters that count as space, such as non-breaking spaces). worded :: Applicative f => IndexedLensLike' Int f String String worded f = fmap unwords . conjoined traverse (indexing traverse) f . words {-# INLINE worded #-} -- | A 'Fold' over the individual 'lines' of a 'String'. -- -- @ -- 'lined' :: 'Fold' 'String' 'String' -- 'lined' :: 'Traversal'' 'String' 'String' -- @ -- -- @ -- 'lined' :: 'IndexedFold' 'Int' 'String' 'String' -- 'lined' :: 'IndexedTraversal'' 'Int' 'String' 'String' -- @ -- -- Note: This function type-checks as a 'Traversal' but it doesn't satisfy the laws. It's only valid to use it -- when you don't insert any newline characters while traversing, and if your original 'String' contains only -- isolated newline characters. lined :: Applicative f => IndexedLensLike' Int f String String lined f = fmap (intercalate "\n") . conjoined traverse (indexing traverse) f . lines {-# INLINE lined #-} -------------------------- -- Fold/Getter combinators -------------------------- -- | Map each part of a structure viewed through a 'Lens', 'Getter', -- 'Fold' or 'Traversal' to a monoid and combine the results. -- -- >>> foldMapOf (folded . both . _Just) Sum [(Just 21, Just 21)] -- Sum {getSum = 42} -- -- @ -- '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' :: 'Semigroup' r => 'Fold1' 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' :: 'Semigroup' r => 'Traversal1'' 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 :: Getting r s a -> (a -> r) -> s -> r foldMapOf = coerce {-# INLINE foldMapOf #-} -- | Combine the elements of a structure viewed through a 'Lens', 'Getter', -- 'Fold' or 'Traversal' using a monoid. -- -- >>> foldOf (folded.folded) [[Sum 1,Sum 4],[Sum 8, Sum 8],[Sum 21]] -- Sum {getSum = 42} -- -- @ -- '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 = getConst #. l Const {-# 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 :: Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r foldrOf l f z = flip appEndo z . 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 #-} -- | Extract a 'NonEmpty' of the targets of 'Fold1'. -- -- >>> toNonEmptyOf both1 ("hello", "world") -- "hello" :| ["world"] -- -- @ -- 'toNonEmptyOf' :: 'Getter' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Fold1' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Lens'' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Iso'' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Traversal1'' s a -> s -> NonEmpty a -- @ toNonEmptyOf :: Getting (NonEmptyDList a) s a -> s -> NonEmpty a toNonEmptyOf l = flip getNonEmptyDList [] . foldMapOf l (NonEmptyDList #. (:|)) -- | Calls 'pure' on the target of a 'Lens', 'Getter', or 'Iso'. -- -- Calls 'pure' on the targets of a 'Traversal', 'Fold', or 'Prism', and -- combines them with '<|>' (or `empty` if none). Intuitively, it collects -- targets into an 'Alternative' until the container fills up or it runs out of -- targets, whichever comes first. -- -- Generalizes 'toListOf' and '(^?)'. -- -- >>> altOf both ("hello", "world") :: [String] -- ["hello","world"] -- >>> altOf both ("hello", "world") :: Maybe String -- Just "hello" -- -- @ -- 'altOf' :: Applicative f => 'Lens'' s a -> s -> f a -- 'altOf' :: Applicative f => 'Getter' s a -> s -> f a -- 'altOf' :: Applicative f => 'Iso'' s a -> s -> f a -- -- 'altOf' :: Alternative f => 'Traversal'' s a -> s -> f a -- 'altOf' :: Alternative f => 'Fold' s a -> s -> f a -- 'altOf' :: Alternative f => 'Prism'' s a -> s -> f a -- @ altOf :: Applicative f => Getting (Alt f a) s a -> s -> f a altOf l = getAlt #. views l (Alt #. pure) {-# INLINE altOf #-} -- | A convenient infix (flipped) version of 'toListOf'. -- -- >>> [[1,2],[3]]^..id -- [[[1,2],[3]]] -- >>> [[1,2],[3]]^..traverse -- [[1,2],[3]] -- >>> [[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::Int)) -- True -- -- @ -- 'Data.Foldable.any' ≡ 'anyOf' 'folded' -- @ -- -- @ -- 'ianyOf' l ≡ 'anyOf' 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 :: Getting Any s a -> (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 :: Getting All s a -> (a -> Bool) -> s -> Bool allOf l f = getAll #. foldMapOf l (All #. f) {-# INLINE allOf #-} -- | Returns 'True' only if no targets of a 'Fold' satisfy a predicate. -- -- >>> noneOf each (is _Nothing) (Just 3, Just 4, Just 5) -- True -- >>> noneOf (folded.folded) (<10) [[13,99,20],[3,71,42]] -- False -- -- @ -- 'inoneOf' l = 'noneOf' l '.' 'Indexed' -- @ -- -- @ -- 'noneOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ noneOf :: Getting Any s a -> (a -> Bool) -> s -> Bool noneOf l f = not . anyOf l f {-# INLINE noneOf #-} -- | Calculate the 'Product' of every number targeted by a 'Fold'. -- -- >>> productOf both (4,5) -- 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' 'Product' '.' '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_ :: Functor f => Getting (Traversed r f) s a -> (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_ :: Functor f => Getting (Traversed r f) s a -> s -> (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_ #-} -- | Traverse over all of the targets of a 'Fold1', computing an 'Apply' based answer. -- -- As long as you have 'Applicative' or 'Functor' effect you are better using 'traverseOf_'. -- The 'traverse1Of_' is useful only when you have genuine 'Apply' effect. -- -- >>> traverse1Of_ both1 (\ks -> Map.fromList [ (k, ()) | k <- ks ]) ("abc", "bcd") -- fromList [('b',()),('c',())] -- -- @ -- 'traverse1Of_' :: 'Apply' f => 'Fold1' s a -> (a -> f r) -> s -> f () -- @ -- -- @since 4.16 traverse1Of_ :: Functor f => Getting (TraversedF r f) s a -> (a -> f r) -> s -> f () traverse1Of_ l f = void . getTraversedF #. foldMapOf l (TraversedF #. f) {-# INLINE traverse1Of_ #-} -- | See 'forOf_' and 'traverse1Of_'. -- -- >>> for1Of_ both1 ("abc", "bcd") (\ks -> Map.fromList [ (k, ()) | k <- ks ]) -- fromList [('b',()),('c',())] -- -- @ -- 'for1Of_' :: 'Apply' f => 'Fold1' s a -> s -> (a -> f r) -> f () -- @ -- -- @since 4.16 for1Of_ :: Functor f => Getting (TraversedF r f) s a -> s -> (a -> f r) -> f () for1Of_ = flip . traverse1Of_ {-# INLINE for1Of_ #-} -- | See 'sequenceAOf_' and 'traverse1Of_'. -- -- @ -- 'sequence1Of_' :: 'Apply' f => 'Fold1' s (f a) -> s -> f () -- @ -- -- @since 4.16 sequence1Of_ :: Functor f => Getting (TraversedF a f) s (f a) -> s -> f () sequence1Of_ l = void . getTraversedF #. foldMapOf l TraversedF {-# INLINE sequence1Of_ #-} -- | 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_ :: Monad m => Getting (Sequenced r m) s a -> (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_ :: Monad m => Getting (Sequenced r m) s a -> s -> (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 (<|>) 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 :: Getting [r] s a -> (a -> [r]) -> s -> [r] concatMapOf = coerce {-# 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 = getConst #. l Const {-# 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. This is because '^?' works by using the -- 'Data.Monoid.First' monoid, which can occasionally cause space leaks. -- -- >>> Left 4 ^?_Left -- Just 4 -- -- >>> Right 4 ^?_Left -- Nothing -- -- >>> "world" ^? ix 3 -- Just 'l' -- -- >>> "world" ^? ix 20 -- Nothing -- -- This operator works as an infix version of 'preview'. -- -- @ -- ('^?') ≡ 'flip' 'preview' -- @ -- -- It may be helpful to think of '^?' as having one of the following -- more specialized types: -- -- @ -- ('^?') :: 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 -- @ (^?!) :: HasCallStack => 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 @'preview'@ or @^?'@ -- and gives you back access to the outermost 'Just' constructor more quickly, but does so -- in a way that builds an intermediate structure, and thus may have worse -- constant factors. This also means that it can not be used in any 'Control.Monad.Reader.MonadReader', -- but must instead have 's' passed as its last argument, unlike 'preview'. -- -- Note: this could been named `headOf`. -- -- >>> 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 'Data.Semigroup.First' entry of a 'Fold1' or 'Traversal1' or the result from a 'Getter' or 'Lens'. -- -- >>> first1Of traverse1 (1 :| [2..10]) -- 1 -- -- >>> first1Of both1 (1,2) -- 1 -- -- /Note:/ this is different from '^.'. -- -- >>> first1Of traverse1 ([1,2] :| [[3,4],[5,6]]) -- [1,2] -- -- >>> ([1,2] :| [[3,4],[5,6]]) ^. traverse1 -- [1,2,3,4,5,6] -- -- @ -- 'first1Of' :: 'Getter' s a -> s -> a -- 'first1Of' :: 'Fold1' s a -> s -> a -- 'first1Of' :: 'Lens'' s a -> s -> a -- 'first1Of' :: 'Iso'' s a -> s -> a -- 'first1Of' :: 'Traversal1'' s a -> s -> a -- @ first1Of :: Getting (Semi.First a) s a -> s -> a first1Of l = Semi.getFirst . foldMapOf l Semi.First -- | 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 #-} -- | Retrieve the 'Data.Semigroup.Last' entry of a 'Fold1' or 'Traversal1' or retrieve the result -- from a 'Getter' or 'Lens'.o -- -- >>> last1Of traverse1 (1 :| [2..10]) -- 10 -- -- >>> last1Of both1 (1,2) -- 2 -- -- @ -- 'last1Of' :: 'Getter' s a -> s -> 'Maybe' a -- 'last1Of' :: 'Fold1' s a -> s -> 'Maybe' a -- 'last1Of' :: 'Lens'' s a -> s -> 'Maybe' a -- 'last1Of' :: 'Iso'' s a -> s -> 'Maybe' a -- 'last1Of' :: 'Traversal1'' s a -> s -> 'Maybe' a -- @ last1Of :: Getting (Semi.Last a) s a -> s -> a last1Of l = Semi.getLast . foldMapOf l Semi.Last -- | 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'. -- -- @ -- 'not' '.' '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 maximum element targeted by a 'Fold1' or 'Traversal1'. -- -- >>> maximum1Of traverse1 (1 :| [2..10]) -- 10 -- -- @ -- 'maximum1Of' :: 'Ord' a => 'Getter' s a -> s -> a -- 'maximum1Of' :: 'Ord' a => 'Fold1' s a -> s -> a -- 'maximum1Of' :: 'Ord' a => 'Iso'' s a -> s -> a -- 'maximum1Of' :: 'Ord' a => 'Lens'' s a -> s -> a -- 'maximum1Of' :: 'Ord' a => 'Traversal1'' s a -> s -> a -- @ maximum1Of :: Ord a => Getting (Semi.Max a) s a -> s -> a maximum1Of l = Semi.getMax . foldMapOf l Semi.Max {-# INLINE maximum1Of #-} -- | 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 minimum element targeted by a 'Fold1' or 'Traversal1'. -- -- >>> minimum1Of traverse1 (1 :| [2..10]) -- 1 -- -- @ -- 'minimum1Of' :: 'Ord' a => 'Getter' s a -> s -> a -- 'minimum1Of' :: 'Ord' a => 'Fold1' s a -> s -> a -- 'minimum1Of' :: 'Ord' a => 'Iso'' s a -> s -> a -- 'minimum1Of' :: 'Ord' a => 'Lens'' s a -> s -> a -- 'minimum1Of' :: 'Ord' a => 'Traversal1'' s a -> s -> a -- @ minimum1Of :: Ord a => Getting (Semi.Min a) s a -> s -> a minimum1Of l = Semi.getMin . foldMapOf l Semi.Min {-# INLINE minimum1Of #-} -- | 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 :: Getting (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a findOf l f = foldrOf l (\a y -> if f a then Just a else y) Nothing {-# INLINE findOf #-} -- | The 'findMOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'), -- a monadic predicate and a structure and returns in the monad the leftmost element of the structure -- matching the predicate, or 'Nothing' if there is no such element. -- -- >>> findMOf each ( \x -> print ("Checking " ++ show x) >> return (even x)) (1,3,4,6) -- "Checking 1" -- "Checking 3" -- "Checking 4" -- Just 4 -- -- >>> findMOf each ( \x -> print ("Checking " ++ show x) >> return (even x)) (1,3,5,7) -- "Checking 1" -- "Checking 3" -- "Checking 5" -- "Checking 7" -- Nothing -- -- @ -- 'findMOf' :: ('Monad' m, 'Getter' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' :: ('Monad' m, 'Fold' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' :: ('Monad' m, 'Iso'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' :: ('Monad' m, 'Lens'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' :: ('Monad' m, 'Traversal'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- @ -- -- @ -- 'findMOf' 'folded' :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m (Maybe a) -- 'ifindMOf' l ≡ 'findMOf' l '.' 'Indexed' -- @ -- -- A simpler version that didn't permit indexing, would be: -- -- @ -- 'findMOf' :: Monad m => 'Getting' ('Endo' (m ('Maybe' a))) s a -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' l p = 'foldrOf' l (\a y -> p a >>= \x -> if x then return ('Just' a) else y) $ return 'Nothing' -- @ findMOf :: Monad m => Getting (Endo (m (Maybe a))) s a -> (a -> m Bool) -> s -> m (Maybe a) findMOf l f = foldrOf l (\a y -> f a >>= \r -> if r then return (Just a) else y) $ return Nothing {-# INLINE findMOf #-} -- | The 'lookupOf' function takes a 'Fold' (or 'Getter', 'Traversal', -- 'Lens', 'Iso', etc.), a key, and a structure containing key/value pairs. -- It returns the first value corresponding to the given key. This function -- generalizes 'lookup' to work on an arbitrary 'Fold' instead of lists. -- -- >>> lookupOf folded 4 [(2, 'a'), (4, 'b'), (4, 'c')] -- Just 'b' -- -- >>> lookupOf each 2 [(2, 'a'), (4, 'b'), (4, 'c')] -- Just 'a' -- -- @ -- 'lookupOf' :: 'Eq' k => 'Fold' s (k,v) -> k -> s -> 'Maybe' v -- @ lookupOf :: Eq k => Getting (Endo (Maybe v)) s (k,v) -> k -> s -> Maybe v lookupOf l k = foldrOf l (\(k',v) next -> if k == k' then Just v else next) Nothing {-# INLINE lookupOf #-} -- | 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 :: HasCallStack => Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") (foldrOf l mf Nothing xs) where 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 :: HasCallStack => Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where 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' :: HasCallStack => Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where 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' :: HasCallStack => Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where 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' :: 'Traversal'' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Lens'' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Iso'' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- 'pre' :: 'Prism'' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- @ pre :: Getting (First a) s a -> IndexPreservingGetter s (Maybe a) pre l = dimap (getFirst . getConst #. l (Const #. First #. Just)) phantom {-# 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' :: 'IndexedTraversal'' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- 'ipre' :: '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 . getConst #. l (Indexed $ \i a -> Const (First (Just (i, a))))) phantom {-# INLINE ipre #-} ------------------------------------------------------------------------------ -- Preview ------------------------------------------------------------------------------ -- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result -- from a 'Getter' or 'Lens'). See also 'firstOf' and '^?', which are similar with -- some subtle differences (explained below). -- -- @ -- 'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded' -- @ -- -- @ -- 'preview' = 'view' '.' 'pre' -- @ -- -- -- Unlike '^?', this function uses a -- 'Control.Monad.Reader.MonadReader' to read the value to be focused in on. -- This allows one to pass the value as the last argument by using the -- 'Control.Monad.Reader.MonadReader' instance for @(->) s@ -- However, it may also be used as part of some deeply nested transformer stack. -- -- 'preview' uses a monoidal value to obtain the result. -- This means that it generally has good performance, but can occasionally cause space leaks -- or even stack overflows on some data types. -- There is another function, 'firstOf', which avoids these issues at the cost of -- a slight constant performance cost and a little less flexibility. -- -- It may be helpful to think of 'preview' as having one of the following -- more specialized types: -- -- @ -- '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 -- @ -- -- -- @ -- '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) => Optical p q (Backwards f) s t a b -> Optical p q f s t a b backwards l f = forwards #. l (Backwards #. f) {-# INLINE backwards #-} ------------------------------------------------------------------------------ -- 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 = coerce {-# 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 f z = flip appEndo z . getConst #. l (Const #. Endo #. Indexed f) {-# 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 = coerce {-# 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 = coerce {-# INLINE iallOf #-} -- | Return whether or not none of the elements viewed through an 'IndexedFold' or 'IndexedTraversal' -- satisfy a predicate, with access to the @i@. -- -- When you don't need access to the index then 'noneOf' is more flexible in what it accepts. -- -- @ -- 'noneOf' l ≡ 'inoneOf' l '.' 'const' -- @ -- -- @ -- 'inoneOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'inoneOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'inoneOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'inoneOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ inoneOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool inoneOf l f = not . ianyOf l f {-# INLINE inoneOf #-} -- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the @i@, discarding the results. -- -- When you don't need access to the index then 'traverseOf_' is more flexible in what it accepts. -- -- @ -- '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 f = void . getTraversed #. getConst #. l (Const #. Traversed #. Indexed f) {-# 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 f = liftM skip . getSequenced #. getConst #. l (Const #. Sequenced #. Indexed f) {-# 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 'ifindOf' function takes an 'IndexedFold' or 'IndexedTraversal', a predicate that is also -- supplied the index, a structure and returns the left-most element of the structure -- matching the predicate, or 'Nothing' if there is no such element. -- -- 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 f = ifoldrOf l (\i a y -> if f i a then Just a else y) Nothing {-# INLINE ifindOf #-} -- | The 'ifindMOf' function takes an 'IndexedFold' or 'IndexedTraversal', a monadic predicate that is also -- supplied the index, a structure and returns in the monad the left-most element of the structure -- matching the predicate, or 'Nothing' if there is no such element. -- -- When you don't need access to the index then 'findMOf' is more flexible in what it accepts. -- -- @ -- 'findMOf' l ≡ 'ifindMOf' l '.' 'const' -- @ -- -- @ -- 'ifindMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) -- 'ifindMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) -- 'ifindMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) -- 'ifindMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) -- @ ifindMOf :: Monad m => IndexedGetting i (Endo (m (Maybe a))) s a -> (i -> a -> m Bool) -> s -> m (Maybe a) ifindMOf l f = ifoldrOf l (\i a y -> f i a >>= \r -> if r then return (Just a) else y) $ return Nothing {-# INLINE ifindMOf #-} -- | /Strictly/ fold right over the elements of a structure with an index. -- -- When you don't need access to the index then 'foldrOf'' is more flexible in what it accepts. -- -- @ -- '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' 'snd' '.' '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) -- @ (^@?!) :: HasCallStack => s -> IndexedGetting i (Endo (i, a)) s a -> (i, a) s ^@?! l = ifoldrOf l (\i x _ -> (i,x)) (error "(^@?!): empty Fold") s {-# INLINE (^@?!) #-} -- | Retrieve the index of the first value targeted by a 'IndexedFold' or 'IndexedTraversal' which is equal to a given value. -- -- @ -- 'Data.List.elemIndex' ≡ 'elemIndexOf' 'folded' -- @ -- -- @ -- 'elemIndexOf' :: 'Eq' a => 'IndexedFold' i s a -> a -> s -> 'Maybe' i -- 'elemIndexOf' :: 'Eq' a => 'IndexedTraversal'' i s a -> a -> s -> 'Maybe' i -- @ elemIndexOf :: Eq a => IndexedGetting i (First i) s a -> a -> s -> Maybe i elemIndexOf l a = findIndexOf l (a ==) {-# INLINE elemIndexOf #-} -- | Retrieve the indices of the values targeted by a 'IndexedFold' or 'IndexedTraversal' which are equal to a given value. -- -- @ -- 'Data.List.elemIndices' ≡ 'elemIndicesOf' 'folded' -- @ -- -- @ -- 'elemIndicesOf' :: 'Eq' a => 'IndexedFold' i s a -> a -> s -> [i] -- 'elemIndicesOf' :: 'Eq' a => 'IndexedTraversal'' i s a -> a -> s -> [i] -- @ elemIndicesOf :: Eq a => IndexedGetting i (Endo [i]) s a -> a -> s -> [i] elemIndicesOf l a = findIndicesOf l (a ==) {-# INLINE elemIndicesOf #-} -- | Retrieve the index of the first value targeted by a 'IndexedFold' or 'IndexedTraversal' which satisfies a predicate. -- -- @ -- 'Data.List.findIndex' ≡ 'findIndexOf' 'folded' -- @ -- -- @ -- 'findIndexOf' :: 'IndexedFold' i s a -> (a -> 'Bool') -> s -> 'Maybe' i -- 'findIndexOf' :: 'IndexedTraversal'' i s a -> (a -> 'Bool') -> s -> 'Maybe' i -- @ findIndexOf :: IndexedGetting i (First i) s a -> (a -> Bool) -> s -> Maybe i findIndexOf l p = preview (l . filtered p . asIndex) {-# INLINE findIndexOf #-} -- | Retrieve the indices of the values targeted by a 'IndexedFold' or 'IndexedTraversal' which satisfy a predicate. -- -- @ -- 'Data.List.findIndices' ≡ 'findIndicesOf' 'folded' -- @ -- -- @ -- 'findIndicesOf' :: 'IndexedFold' i s a -> (a -> 'Bool') -> s -> [i] -- 'findIndicesOf' :: 'IndexedTraversal'' i s a -> (a -> 'Bool') -> s -> [i] -- @ findIndicesOf :: IndexedGetting i (Endo [i]) s a -> (a -> Bool) -> s -> [i] findIndicesOf l p = toListOf (l . filtered p . asIndex) {-# INLINE findIndicesOf #-} ------------------------------------------------------------------------------- -- 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 'ifiltered' 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) -> Optical' p (Indexed i) f a a ifiltered p f = Indexed $ \i a -> if p i a then indexed f i a else pure a {-# INLINE ifiltered #-} -- | 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 -- @ -- -- Note: Applying 'itakingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still allow you to use it as a -- pseudo-'IndexedTraversal', but if you change the value of any target to one where the predicate returns -- 'False', then you will break the 'Traversal' laws and 'Traversal' fusion will no longer be sound. itakingWhile :: (Indexable i p, Profunctor q, Contravariant f, Applicative f) => (i -> a -> Bool) -> Optical' (Indexed i) q (Const (Endo (f s))) s a -> Optical' p q f s a itakingWhile p l f = (flip appEndo noEffect .# getConst) `rmap` l g where g = Indexed $ \i a -> Const . Endo $ if p i a then (indexed f i a *>) else const noEffect {-# INLINE itakingWhile #-} -- | Obtain an 'IndexedFold' by dropping elements from another 'IndexedFold', 'IndexedLens', 'IndexedGetter' or 'IndexedTraversal' while a predicate holds. -- -- @ -- '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 -- @ -- -- Note: As with `droppingWhile` 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 first target to one -- 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) -> Optical (Indexed i) q (Compose (State Bool) f) s t a a -> Optical p q f s t a a idroppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where g = Indexed $ \ i a -> Compose $ state $ \b -> let b' = b && p i a in (if b' then pure a else indexed f i a, b') {-# INLINE idroppingWhile #-} ------------------------------------------------------------------------------ -- Misc. ------------------------------------------------------------------------------ skip :: a -> () skip _ = () {-# INLINE skip #-} ------------------------------------------------------------------------------ -- Folds with Reified Monoid ------------------------------------------------------------------------------ -- | Fold a value using a specified 'Fold' and 'Monoid' operations. -- This is like 'foldBy' where the 'Foldable' instance can be -- manually specified. -- -- @ -- 'foldByOf' 'folded' ≡ 'foldBy' -- @ -- -- @ -- 'foldByOf' :: 'Getter' s a -> (a -> a -> a) -> a -> s -> a -- 'foldByOf' :: 'Fold' s a -> (a -> a -> a) -> a -> s -> a -- 'foldByOf' :: 'Lens'' s a -> (a -> a -> a) -> a -> s -> a -- 'foldByOf' :: 'Traversal'' s a -> (a -> a -> a) -> a -> s -> a -- 'foldByOf' :: 'Iso'' s a -> (a -> a -> a) -> a -> s -> a -- @ -- -- >>> foldByOf both (++) [] ("hello","world") -- "helloworld" foldByOf :: Fold s a -> (a -> a -> a) -> a -> s -> a foldByOf l f z = reifyMonoid f z (foldMapOf l ReflectedMonoid) -- | Fold a value using a specified 'Fold' and 'Monoid' operations. -- This is like 'foldMapBy' where the 'Foldable' instance can be -- manually specified. -- -- @ -- 'foldMapByOf' 'folded' ≡ 'foldMapBy' -- @ -- -- @ -- 'foldMapByOf' :: 'Getter' s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r -- 'foldMapByOf' :: 'Fold' s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r -- 'foldMapByOf' :: 'Traversal'' s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r -- 'foldMapByOf' :: 'Lens'' s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r -- 'foldMapByOf' :: 'Iso'' s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r -- @ -- -- >>> foldMapByOf both (+) 0 length ("hello","world") -- 10 foldMapByOf :: Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r foldMapByOf l f z g = reifyMonoid f z (foldMapOf l (ReflectedMonoid #. g)) lens-5.2.3/src/Control/Lens/Getter.hs0000644000000000000000000004637507346545000015570 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} -- Disable the warnings generated by 'Control.Lens.Getter.to', 'ito', 'like', 'ilike'. -- These functions are intended to produce 'Getters'. Without this constraint -- users would get warnings when annotating types at uses of these functions. {-# OPTIONS_GHC -Wno-redundant-constraints #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Getter -- Copyright : (C) 2012-16 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 'Const' to obtain: -- -- @type 'Getting' r s a = (a -> 'Const' r a) -> s -> 'Const' r s@ -- -- If we restrict access to knowledge about the type 'r', we could get: -- -- @type 'Getter' s a = forall r. 'Getting' r s a@ -- -- However, for 'Getter' (but not for 'Getting') we actually permit any -- functor @f@ which is an instance of both 'Functor' and 'Contravariant': -- -- @type 'Getter' s a = forall f. ('Contravariant' f, 'Functor' 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. -- -- A common question is whether you can combine multiple 'Getter's to -- retrieve multiple values. Recall that all 'Getter's are 'Fold's and that -- we have a @'Monoid' m => 'Applicative' ('Const' m)@ instance to play -- with. Knowing this, we can use @'Data.Semigroup.<>'@ to glue 'Fold's -- together: -- -- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5) -- [2,3,5] -- ------------------------------------------------------------------------------- module Control.Lens.Getter ( -- * Getters Getter, IndexedGetter , Getting, IndexedGetting , Accessing -- * Building Getters , to , ito , like , ilike -- * 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(..) , getting , Const(..) ) where import Prelude () import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Control.Lens.Type import Control.Monad.Reader.Class as Reader import Control.Monad.State as State import Control.Monad.Writer (MonadWriter (..)) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.List.Lens -- >>> import Data.Semigroup (Semigroup (..)) -- >>> 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 an (index-preserving) 'Getter' from an arbitrary Haskell function. -- -- @ -- 'Control.Lens.Getter.to' f '.' 'Control.Lens.Getter.to' g ≡ 'Control.Lens.Getter.to' (g '.' f) -- @ -- -- @ -- a '^.' 'Control.Lens.Getter.to' f ≡ f a -- @ -- -- >>> a ^.to f -- f a -- -- >>> ("hello","world")^.to snd -- "world" -- -- >>> 5^.to succ -- 6 -- -- >>> (0, -5)^._2.to abs -- 5 -- -- @ -- 'Control.Lens.Getter.to' :: (s -> a) -> 'IndexPreservingGetter' s a -- @ to :: (Profunctor p, Contravariant f) => (s -> a) -> Optic' p f s a to k = dimap k (contramap k) {-# INLINE to #-} -- | -- @ -- 'ito' :: (s -> (i, a)) -> 'IndexedGetter' i s a -- @ ito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> Over' p f s a ito k = dimap k (contramap (snd . k)) . uncurry . indexed {-# INLINE ito #-} -- | Build an constant-valued (index-preserving) 'Getter' from an arbitrary Haskell value. -- -- @ -- 'like' a '.' 'like' b ≡ 'like' b -- a '^.' 'like' b ≡ b -- a '^.' 'like' b ≡ a '^.' 'Control.Lens.Getter.to' ('const' b) -- @ -- -- This can be useful as a second case 'failing' a 'Fold' -- e.g. @foo `failing` 'like' 0@ -- -- @ -- 'like' :: a -> 'IndexPreservingGetter' s a -- @ like :: (Profunctor p, Contravariant f, Functor f) => a -> Optic' p f s a like a = to (const a) {-# INLINE like #-} -- | -- @ -- 'ilike' :: i -> a -> 'IndexedGetter' i s a -- @ ilike :: (Indexable i p, Contravariant f, Functor f) => i -> a -> Over' p f s a ilike i a = ito (const (i, a)) {-# INLINE ilike #-} -- | 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 a@, then when @r@ is a 'Data.Monoid.Monoid', then -- you can pass a 'Control.Lens.Fold.Fold' (or -- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a -- 'Getter' or 'Lens'. type Getting r s a = (a -> Const r a) -> s -> Const r s -- | Used to consume an 'Control.Lens.Fold.IndexedFold'. type IndexedGetting i m s a = Indexed i a (Const m a) -> s -> Const m s -- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds -- in a highly general fashion. type Accessing p m s a = p a (Const m a) -> s -> Const 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' '.' 'Control.Lens.Getter.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 (getConst #. l Const) {-# 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 '.' 'Control.Lens.Getter.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: -- -- @ -- 'views' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r -- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r -- 'views' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> m r -- 'views' :: 'MonadReader' s m => 'Lens'' s a -> (a -> r) -> m r -- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r -- @ -- -- @ -- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r -- @ views :: MonadReader s m => LensLike' (Const r) s a -> (a -> r) -> m r views l f = Reader.asks (coerce l 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 = getConst (l Const 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 :: MonadState s m => LensLike' (Const r) s a -> (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 (getConst #. l (Indexed $ \i -> Const #. (,) 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 f = asks (coerce l f) {-# 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 (getConst #. l (Indexed $ \i -> Const #. (,) 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 f = gets (coerce l f) {-# INLINE iuses #-} -- | View the index and value of an 'IndexedGetter' or 'IndexedLens'. -- -- 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..'). -- -- @ -- ('^@.') :: 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 = getConst $ l (Indexed $ \i -> Const #. (,) i) s {-# INLINE (^@.) #-} -- | Coerce a 'Getter'-compatible 'Optical' to an 'Optical''. This -- is useful when using a 'Traversal' that is not simple as a 'Getter' or a -- 'Fold'. -- -- @ -- 'getting' :: 'Traversal' s t a b -> 'Fold' s a -- 'getting' :: 'Lens' s t a b -> 'Getter' s a -- 'getting' :: 'IndexedTraversal' i s t a b -> 'IndexedFold' i s a -- 'getting' :: 'IndexedLens' i s t a b -> 'IndexedGetter' i s a -- @ getting :: (Profunctor p, Profunctor q, Functor f, Contravariant f) => Optical p q f s t a b -> Optical' p q f s a getting l f = rmap phantom . l $ rmap phantom f lens-5.2.3/src/Control/Lens/Indexed.hs0000644000000000000000000002670507346545000015711 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- vector, hashable #endif #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Indexed -- Copyright : (C) 2012-16 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(..) , (<.), (<.>), (.>) , selfIndex , reindexed , icompose , indexing , indexing64 -- * Indexed Functors , FunctorWithIndex(..) -- ** Indexed Functor Combinators , imapped -- * Indexed Foldables , FoldableWithIndex(..) -- ** Indexed Foldable Combinators , ifolded , iany , iall , inone, none , 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 , itraversed , ifor , imapM , iforM , imapAccumR , imapAccumL -- * Indexed Folds with Reified Monoid , ifoldMapBy , ifoldMapByOf -- * Indexed Traversals with Reified Applicative , itraverseBy , itraverseByOf ) where import Prelude () import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal.Fold import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type import Data.Reflection import Data.HashMap.Lazy (HashMap) import Data.IntMap (IntMap) import Data.Map (Map) import Data.Sequence (Seq) import Data.Vector (Vector) import qualified Data.HashMap.Lazy as HashMap import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Vector as Vector infixr 9 <.>, <., .> -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import qualified Data.Map as Map -- | Compose an 'Indexed' function with a non-indexed function. -- -- Mnemonically, the @<@ points to the indexing we want to preserve. -- -- >>> let nestedMap = (fmap Map.fromList . Map.fromList) [(1, [(10, "one,ten"), (20, "one,twenty")]), (2, [(30, "two,thirty"), (40,"two,forty")])] -- >>> nestedMap^..(itraversed<.itraversed).withIndex -- [(1,"one,ten"),(1,"one,twenty"),(2,"two,thirty"),(2,"two,forty")] (<.) :: 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@. -- -- >>> let nestedMap = (fmap Map.fromList . Map.fromList) [(1, [(10, "one,ten"), (20, "one,twenty")]), (2, [(30, "two,thirty"), (40,"two,forty")])] -- >>> nestedMap^..(itraversed.>itraversed).withIndex -- [(10,"one,ten"),(20,"one,twenty"),(30,"two,thirty"),(40,"two,forty")] (.>) :: (st -> r) -> (kab -> st) -> kab -> r (.>) = (.) {-# INLINE (.>) #-} -- | Use a value itself as its own index. This is essentially an indexed version of 'id'. -- -- Note: When used to modify the value, this can break the index requirements assumed by 'indices' and similar, -- so this is only properly an 'IndexedGetter', but it can be used as more. -- -- @ -- 'selfIndex' :: 'IndexedGetter' a a b -- @ selfIndex :: Indexable a p => p a fb -> a -> fb selfIndex f a = indexed f a a {-# INLINE selfIndex #-} -- | 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. -- -- >>> let nestedMap = (fmap Map.fromList . Map.fromList) [(1, [(10, "one,ten"), (20, "one,twenty")]), (2, [(30, "two,thirty"), (40,"two,forty")])] -- >>> nestedMap^..(itraversed<.>itraversed).withIndex -- [((1,10),"one,ten"),((1,20),"one,twenty"),((2,30),"two,thirty"),((2,40),"two,forty")] (<.>) :: 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 #-} ------------------------------------------------------------------------------- -- 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) -> Optical' p (Indexed i) f a a indices p f = Indexed $ \i a -> if p i then indexed f i a else pure a {-# INLINE indices #-} -- | 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 -> Optical' p (Indexed i) f a a index j f = Indexed $ \i a -> if j == i then indexed f i a else pure a {-# INLINE index #-} ------------------------------------------------------------------------------- -- FunctorWithIndex ------------------------------------------------------------------------------- -- | 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 ------------------------------------------------------------------------------- -- | The 'IndexedFold' of a 'FoldableWithIndex' container. -- -- @'ifolded' '.' 'asIndex'@ is a fold over the keys of a 'FoldableWithIndex'. -- -- >>> Data.Map.fromList [(2, "hello"), (1, "world")]^..ifolded.asIndex -- [1,2] ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a ifolded = conjoined folded $ \f -> phantom . getFolding . ifoldMap (\i -> Folding #. indexed f i) {-# INLINE ifolded #-} ------------------------------------------------------------------------------- -- TraversableWithIndex ------------------------------------------------------------------------------- -- | The 'IndexedTraversal' of a 'TraversableWithIndex' container. itraversed :: TraversableWithIndex i t => IndexedTraversal i (t a) (t b) a b itraversed = conjoined traverse (itraverse . indexed) {-# INLINE [0] itraversed #-} ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- {-# RULES "itraversed -> mapList" itraversed = sets fmap :: ASetter [a] [b] a b; "itraversed -> imapList" itraversed = isets imap :: AnIndexedSetter Int [a] [b] a b; "itraversed -> foldrList" itraversed = foldring foldr :: Getting (Endo r) [a] a; "itraversed -> ifoldrList" itraversed = ifoldring ifoldr :: IndexedGetting Int (Endo r) [a] a; #-} {-# RULES "itraversed -> mapIntMap" itraversed = sets IntMap.map :: ASetter (IntMap a) (IntMap b) a b; "itraversed -> imapIntMap" itraversed = isets IntMap.mapWithKey :: AnIndexedSetter Int (IntMap a) (IntMap b) a b; "itraversed -> foldrIntMap" itraversed = foldring IntMap.foldr :: Getting (Endo r) (IntMap a) a; "itraversed -> ifoldrIntMap" itraversed = ifoldring IntMap.foldrWithKey :: IndexedGetting Int (Endo r) (IntMap a) a; #-} {-# RULES "itraversed -> mapMap" itraversed = sets Map.map :: ASetter (Map k a) (Map k b) a b; "itraversed -> imapMap" itraversed = isets Map.mapWithKey :: AnIndexedSetter k (Map k a) (Map k b) a b; "itraversed -> foldrMap" itraversed = foldring Map.foldr :: Getting (Endo r) (Map k a) a; "itraversed -> ifoldrMap" itraversed = ifoldring Map.foldrWithKey :: IndexedGetting k (Endo r) (Map k a) a; #-} {-# RULES "itraversed -> mapHashMap" itraversed = sets HashMap.map :: ASetter (HashMap k a) (HashMap k b) a b; "itraversed -> imapHashMap" itraversed = isets HashMap.mapWithKey :: AnIndexedSetter k (HashMap k a) (HashMap k b) a b; "itraversed -> foldrHashMap" itraversed = foldring HashMap.foldr :: Getting (Endo r) (HashMap k a) a; "itraversed -> ifoldrHashMap" itraversed = ifoldring HashMap.foldrWithKey :: IndexedGetting k (Endo r) (HashMap k a) a; #-} {-# RULES "itraversed -> mapSeq" itraversed = sets fmap :: ASetter (Seq a) (Seq b) a b; "itraversed -> imapSeq" itraversed = isets Seq.mapWithIndex :: AnIndexedSetter Int (Seq a) (Seq b) a b; "itraversed -> foldrSeq" itraversed = foldring foldr :: Getting (Endo r) (Seq a) a; "itraversed -> ifoldrSeq" itraversed = ifoldring Seq.foldrWithIndex :: IndexedGetting Int (Endo r) (Seq a) a; #-} {-# RULES "itraversed -> mapVector" itraversed = sets Vector.map :: ASetter (Vector a) (Vector b) a b; "itraversed -> imapVector" itraversed = isets Vector.imap :: AnIndexedSetter Int (Vector a) (Vector b) a b; "itraversed -> foldrVector" itraversed = foldring Vector.foldr :: Getting (Endo r) (Vector a) a; "itraversed -> ifoldrVector" itraversed = ifoldring Vector.ifoldr :: IndexedGetting Int (Endo r) (Vector a) a; #-} ------------------------------------------------------------------------------- -- Indexed Folds with Reified Monoid ------------------------------------------------------------------------------- ifoldMapBy :: FoldableWithIndex i t => (r -> r -> r) -> r -> (i -> a -> r) -> t a -> r ifoldMapBy f z g = reifyMonoid f z (ifoldMap (\i a -> ReflectedMonoid (g i a))) ifoldMapByOf :: IndexedFold i t a -> (r -> r -> r) -> r -> (i -> a -> r) -> t -> r ifoldMapByOf l f z g = reifyMonoid f z (ifoldMapOf l (\i a -> ReflectedMonoid (g i a))) itraverseBy :: TraversableWithIndex i t => (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (i -> a -> f b) -> t a -> f (t b) itraverseBy pur app f = reifyApplicative pur app (itraverse (\i a -> ReflectedApplicative (f i a))) itraverseByOf :: IndexedTraversal i s t a b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (i -> a -> f b) -> s -> f t itraverseByOf l pur app f = reifyApplicative pur app (itraverseOf l (\i a -> ReflectedApplicative (f i a))) lens-5.2.3/src/Control/Lens/Internal.hs0000644000000000000000000000304407346545000016074 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal -- Copyright : (C) 2012-16 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.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.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 lens-5.2.3/src/Control/Lens/Internal/0000755000000000000000000000000007346545000015537 5ustar0000000000000000lens-5.2.3/src/Control/Lens/Internal/Bazaar.hs0000644000000000000000000003146007346545000017277 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RoleAnnotations #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Bazaar -- Copyright : (C) 2012-2016 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' , Bizarre1(..) , Bazaar1(..), Bazaar1' , BazaarT1(..), BazaarT1' ) where import Prelude () import Control.Arrow as Arrow import qualified Control.Category as C import Control.Comonad import Control.Lens.Internal.Prelude import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Data.Functor.Apply import Data.Kind import Data.Profunctor.Rep ------------------------------------------------------------------------------ -- 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 } -- type role Bazaar representatonal nominal nominal nominal -- | 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 C.. sell) {-# INLINE iduplicate #-} instance Corepresentable p => Sellable p (Bazaar p) where sell = cotabulate $ \ w -> Bazaar $ tabulate $ \k -> pure (cosieve 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 #-} x <$ Bazaar k = Bazaar ( (x <$) . k ) {-# INLINE (<$) #-} instance Apply (Bazaar p a b) where (<.>) = (<*>) {-# INLINE (<.>) #-} (.>) = (*>) {-# INLINE (.>) #-} (<.) = (<*) {-# 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 (<*>) #-} #if MIN_VERSION_base(4,10,0) liftA2 f (Bazaar mx) (Bazaar my) = Bazaar $ \pafb -> liftA2 f (mx pafb) (my pafb) {-# INLINE liftA2 #-} #endif Bazaar mx *> Bazaar my = Bazaar $ \pafb -> mx pafb *> my pafb {-# INLINE (*>) #-} Bazaar mx <* Bazaar my = Bazaar $ \pafb -> mx pafb <* my 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 (<@>) #-} (@>) = (*>) {-# INLINE (@>) #-} (<@) = (<*) {-# 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 :: Type -> Type) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } type role BazaarT representational nominal nominal nominal nominal -- | 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 C.. sell) {-# INLINE iduplicate #-} instance Corepresentable p => Sellable p (BazaarT p g) where sell = cotabulate $ \ w -> BazaarT (`cosieve` 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 #-} x <$ BazaarT k = BazaarT ( (x <$) . k ) {-# INLINE (<$) #-} instance Apply (BazaarT p g a b) where (<.>) = (<*>) {-# INLINE (<.>) #-} (.>) = (*>) {-# INLINE (.>) #-} (<.) = (<*) {-# 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 (<*>) #-} #if MIN_VERSION_base(4,10,0) liftA2 f (BazaarT mx) (BazaarT my) = BazaarT $ \pafb -> liftA2 f (mx pafb) (my pafb) {-# INLINE liftA2 #-} #endif BazaarT mf *> BazaarT ma = BazaarT $ \ pafb -> mf pafb *> ma pafb {-# INLINE (*>) #-} 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 (<@>) #-} (@>) = (*>) {-# INLINE (@>) #-} (<@) = (<*) {-# INLINE (<@) #-} instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where contramap _ = (<$) (error "contramap: BazaarT") {-# INLINE contramap #-} instance Contravariant g => Semigroup (BazaarT p g a b t) where BazaarT a <> BazaarT b = BazaarT $ \f -> a f <* b f {-# INLINE (<>) #-} instance Contravariant g => Monoid (BazaarT p g a b t) where mempty = BazaarT $ \_ -> pure (error "mempty: BazaarT") {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) BazaarT a `mappend` BazaarT b = BazaarT $ \f -> a f <* b f {-# INLINE mappend #-} #endif ------------------------------------------------------------------------------ -- Bizarre1 ------------------------------------------------------------------------------ class Profunctor p => Bizarre1 p w | w -> p where bazaar1 :: Apply f => p a (f b) -> w a b t -> f t ------------------------------------------------------------------------------ -- Bazaar1 ------------------------------------------------------------------------------ -- | This is used to characterize a 'Control.Lens.Traversal.Traversal'. -- -- a.k.a. indexed Cartesian store comonad, indexed Kleene store comonad, or an indexed 'FunList'. -- -- -- -- A 'Bazaar1' is like a 'Control.Lens.Traversal.Traversal' that has already been applied to some structure. -- -- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to -- @t@, a @'Bazaar1' a b t@ holds @N@ @a@s and a function from @N@ -- @b@s to @t@, (where @N@ might be infinite). -- -- Mnemonically, a 'Bazaar1' holds many stores and you can easily add more. -- -- This is a final encoding of 'Bazaar1'. newtype Bazaar1 p a b t = Bazaar1 { runBazaar1 :: forall f. Apply f => p a (f b) -> f t } -- type role Bazaar1 representatonal nominal nominal nominal -- | This alias is helpful when it comes to reducing repetition in type signatures. -- -- @ -- type 'Bazaar1'' p a t = 'Bazaar1' p a a t -- @ type Bazaar1' p a = Bazaar1 p a a instance IndexedFunctor (Bazaar1 p) where ifmap f (Bazaar1 k) = Bazaar1 (fmap f . k) {-# INLINE ifmap #-} instance Conjoined p => IndexedComonad (Bazaar1 p) where iextract (Bazaar1 m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} iduplicate (Bazaar1 m) = getCompose $ m (Compose #. distrib sell C.. sell) {-# INLINE iduplicate #-} instance Corepresentable p => Sellable p (Bazaar1 p) where sell = cotabulate $ \ w -> Bazaar1 $ tabulate $ \k -> pure (cosieve k w) {-# INLINE sell #-} instance Profunctor p => Bizarre1 p (Bazaar1 p) where bazaar1 g (Bazaar1 f) = f g {-# INLINE bazaar1 #-} instance Functor (Bazaar1 p a b) where fmap = ifmap {-# INLINE fmap #-} x <$ Bazaar1 k = Bazaar1 ((x <$) . k) {-# INLINE (<$) #-} instance Apply (Bazaar1 p a b) where Bazaar1 mf <.> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb {-# INLINE (<.>) #-} Bazaar1 mf .> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb .> ma pafb {-# INLINE (.>) #-} Bazaar1 mf <. Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <. ma pafb {-# INLINE (<.) #-} instance (a ~ b, Conjoined p) => Comonad (Bazaar1 p a b) where extract = iextract {-# INLINE extract #-} duplicate = iduplicate {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where (<@>) = (<.>) {-# INLINE (<@>) #-} (@>) = (.>) {-# INLINE (@>) #-} (<@) = (<.) {-# INLINE (<@) #-} ------------------------------------------------------------------------------ -- BazaarT1 ------------------------------------------------------------------------------ -- | 'BazaarT1' is like 'Bazaar1', except that it provides a questionable 'Contravariant' instance -- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions. -- -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! newtype BazaarT1 p (g :: Type -> Type) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t } type role BazaarT1 representational nominal nominal nominal nominal -- | This alias is helpful when it comes to reducing repetition in type signatures. -- -- @ -- type 'BazaarT1'' p g a t = 'BazaarT1' p g a a t -- @ type BazaarT1' p g a = BazaarT1 p g a a instance IndexedFunctor (BazaarT1 p g) where ifmap f (BazaarT1 k) = BazaarT1 (fmap f . k) {-# INLINE ifmap #-} instance Conjoined p => IndexedComonad (BazaarT1 p g) where iextract (BazaarT1 m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} iduplicate (BazaarT1 m) = getCompose $ m (Compose #. distrib sell C.. sell) {-# INLINE iduplicate #-} instance Corepresentable p => Sellable p (BazaarT1 p g) where sell = cotabulate $ \ w -> BazaarT1 (`cosieve` w) {-# INLINE sell #-} instance Profunctor p => Bizarre1 p (BazaarT1 p g) where bazaar1 g (BazaarT1 f) = f g {-# INLINE bazaar1 #-} instance Functor (BazaarT1 p g a b) where fmap = ifmap {-# INLINE fmap #-} x <$ BazaarT1 k = BazaarT1 ((x <$) . k) {-# INLINE (<$) #-} instance Apply (BazaarT1 p g a b) where BazaarT1 mf <.> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb {-# INLINE (<.>) #-} BazaarT1 mf .> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb .> ma pafb {-# INLINE (.>) #-} BazaarT1 mf <. BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <. ma pafb {-# INLINE (<.) #-} instance (a ~ b, Conjoined p) => Comonad (BazaarT1 p g a b) where extract = iextract {-# INLINE extract #-} duplicate = iduplicate {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where (<@>) = (<.>) {-# INLINE (<@>) #-} (@>) = (.>) {-# INLINE (@>) #-} (<@) = (<.) {-# INLINE (<@) #-} instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where contramap _ = (<$) (error "contramap: BazaarT1") {-# INLINE contramap #-} instance Contravariant g => Semigroup (BazaarT1 p g a b t) where BazaarT1 a <> BazaarT1 b = BazaarT1 $ \f -> a f <. b f {-# INLINE (<>) #-} lens-5.2.3/src/Control/Lens/Internal/ByteString.hs0000644000000000000000000002071107346545000020166 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens -- Copyright : (C) 2012-2016 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 ( traversedStrictTree, traversedStrictTree8 , traversedLazy, traversedLazy8 ) where import Prelude () import Control.Lens.Type import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Indexed import Control.Lens.Internal.Prelude import Control.Lens.Setter import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BU import Data.Bits import Data.Char import Data.Int (Int64) import Data.Word (Word8) import Foreign.Ptr import Foreign.Storable import Foreign.ForeignPtr import GHC.Base (unsafeChr) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) import GHC.IO (unsafeDupablePerformIO) 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 :: IndexedTraversal' Int B.ByteString Word8 traversedStrictTree pafb bs = unsafeCreate len <$> go 0 len where len = B.length bs 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 = BU.unsafeIndex bs i in (\y ys q -> pokeByteOff q i y >> ys q) <$> indexed pafb (i :: Int) x <*> run (i + 1) j {-# INLINE [0] traversedStrictTree #-} {-# RULES "bytes -> map" traversedStrictTree = sets B.map :: ASetter' B.ByteString Word8; "bytes -> imap" traversedStrictTree = isets imapB :: AnIndexedSetter' Int B.ByteString Word8; "bytes -> foldr" traversedStrictTree = foldring B.foldr :: Getting (Endo r) B.ByteString Word8; "bytes -> ifoldr" traversedStrictTree = ifoldring ifoldrB :: IndexedGetting Int (Endo r) B.ByteString Word8; #-} imapB :: (Int -> Word8 -> Word8) -> B.ByteString -> B.ByteString imapB f = snd . B.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 {-# INLINE imapB #-} ifoldrB :: (Int -> Word8 -> a -> a) -> a -> B.ByteString -> a ifoldrB f z xs = B.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrB #-} -- | 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 :: IndexedTraversal' Int B.ByteString Char traversedStrictTree8 pafb bs = unsafeCreate len <$> go 0 len where len = B.length bs go !i !j | i + grain < j = let k = i + shiftR (j - i) 1 in (\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 = BU.unsafeIndex bs i in (\y ys q -> pokeByteOff q i (c2w y) >> ys q) <$> indexed pafb (i :: Int) (w2c x) <*> run (i + 1) j {-# INLINE [0] traversedStrictTree8 #-} {-# RULES "chars -> map" traversedStrictTree8 = sets B8.map :: ASetter' B.ByteString Char; "chars -> imap" traversedStrictTree8 = isets imapB8 :: AnIndexedSetter' Int B.ByteString Char; "chars -> foldr" traversedStrictTree8 = foldring B8.foldr :: Getting (Endo r) B.ByteString Char; "chars -> ifoldr" traversedStrictTree8 = ifoldring ifoldrB8 :: IndexedGetting Int (Endo r) B.ByteString Char; #-} imapB8 :: (Int -> Char -> Char) -> B.ByteString -> B.ByteString imapB8 f = snd . B8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 {-# INLINE imapB8 #-} ifoldrB8 :: (Int -> Char -> a -> a) -> a -> B.ByteString -> a ifoldrB8 f z xs = B8.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrB8 #-} -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' traversedLazy :: IndexedTraversal' Int64 BL.ByteString Word8 traversedLazy pafb = \lbs -> BL.foldrChunks go (\_ -> pure BL.empty) lbs 0 where go c fcs acc = BL.append . BL.fromStrict <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree pafb c <*> fcs acc' where acc' :: Int64 !acc' = acc + fromIntegral (B.length c) {-# INLINE [1] traversedLazy #-} {-# RULES "sets lazy bytestring" traversedLazy = sets BL.map :: ASetter' BL.ByteString Word8; "isets lazy bytestring" traversedLazy = isets imapBL :: AnIndexedSetter' Int BL.ByteString Word8; "gets lazy bytestring" traversedLazy = foldring BL.foldr :: Getting (Endo r) BL.ByteString Word8; "igets lazy bytestring" traversedLazy = ifoldring ifoldrBL :: IndexedGetting Int (Endo r) BL.ByteString Word8; #-} imapBL :: (Int -> Word8 -> Word8) -> BL.ByteString -> BL.ByteString imapBL f = snd . BL.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 {-# INLINE imapBL #-} ifoldrBL :: (Int -> Word8 -> a -> a) -> a -> BL.ByteString -> a ifoldrBL f z xs = BL.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrBL #-} -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' pretending the bytes are chars. traversedLazy8 :: IndexedTraversal' Int64 BL.ByteString Char traversedLazy8 pafb = \lbs -> BL.foldrChunks go (\_ -> pure BL.empty) lbs 0 where go c fcs acc = BL.append . BL.fromStrict <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree8 pafb c <*> fcs acc' where acc' :: Int64 !acc' = acc + fromIntegral (B.length c) {-# INLINE [1] traversedLazy8 #-} {-# RULES "sets lazy bytestring" traversedLazy8 = sets BL8.map :: ASetter' BL8.ByteString Char; "isets lazy bytestring" traversedLazy8 = isets imapBL8 :: AnIndexedSetter' Int BL8.ByteString Char; "gets lazy bytestring" traversedLazy8 = foldring BL8.foldr :: Getting (Endo r) BL8.ByteString Char; "igets lazy bytestring" traversedLazy8 = ifoldring ifoldrBL8 :: IndexedGetting Int (Endo r) BL8.ByteString Char; #-} imapBL8 :: (Int -> Char -> Char) -> BL8.ByteString -> BL8.ByteString imapBL8 f = snd . BL8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 {-# INLINE imapBL8 #-} ifoldrBL8 :: (Int -> Char -> a -> a) -> a -> BL8.ByteString -> a ifoldrBL8 f z xs = BL8.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrBL8 #-} ------------------------------------------------------------------------------ -- 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 #-} -- | 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 #if MIN_VERSION_bytestring(0,11,0) return $! BI.BS fp l #else return $! BI.PS fp 0 l #endif {-# INLINE create #-} lens-5.2.3/src/Control/Lens/Internal/CTypes.hs0000644000000000000000000000217107346545000017303 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.CTypes -- Copyright : (C) 2012-2016 Edward Kmett, (C) 2017 Ryan Scott -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- In "Control.Lens.Wrapped", we need to muck around with the internals of the -- newtypes in "Foreign.C.Types". Unfortunately, the exact types used varies -- wildly from platform to platform, so trying to manage the imports necessary -- to bring these types in scope can be unwieldy. -- -- To make things easier, we use this module as a way to import everything -- carte blanche that might be used internally in "Foreign.C.Types". For -- now, this consists of all the exports from the "Data.Int" and "Data.Word" -- modules, as well as the 'Ptr' type. ---------------------------------------------------------------------------- module Control.Lens.Internal.CTypes ( module Data.Int , Ptr , module Data.Word ) where import Data.Int import Data.Word import Foreign.Ptr (Ptr) lens-5.2.3/src/Control/Lens/Internal/Context.hs0000644000000000000000000003042707346545000017525 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RoleAnnotations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Context -- Copyright : (C) 2012-2016 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 Prelude () import Control.Arrow import qualified Control.Category as C import Control.Comonad import Control.Comonad.Store.Class import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Data.Kind import Data.Profunctor.Rep 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 {-# MINIMAL iextract, (iduplicate | iextend) #-} -- | 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.cloneLens'. -- -- @'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 -- type role Context representational representational representational 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 role Pretext representational nominal nominal nominal -- | @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 C.. 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 (`cosieve` 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 -- 'Control.Lens.Getter.Getter'-compatibility under limited circumstances. -- This is used internally to permit a number of combinators to gracefully -- degrade when applied to a 'Control.Lens.Fold.Fold' or -- 'Control.Lens.Getter.Getter'. newtype PretextT p (g :: Type -> Type) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } -- really we want PretextT p g a b t to permit the last 3 arguments to be representational iff p and f accept representational arguments -- but that isn't currently an option in GHC type role PretextT representational nominal nominal nominal nominal -- | @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 C.. 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 (`cosieve` 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 . sieve qab {-# INLINE coarr #-} lens-5.2.3/src/Control/Lens/Internal/Deque.hs0000644000000000000000000001357007346545000017144 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Deque -- Copyright : (C) 2012-16 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 Prelude () import Control.Lens.Cons import Control.Lens.Fold import Control.Lens.Indexed hiding ((<.>)) import Control.Lens.Internal.Prelude hiding (null) import Control.Lens.Iso import Control.Lens.Lens import Control.Lens.Prism import Control.Monad import Data.Foldable (toList) import Data.Function import Data.Functor.Bind import Data.Functor.Plus import Data.Functor.Reverse -- $setup -- >>> import Control.Applicative (empty) -- | 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 if a 'Deque' is 'empty'. -- -- >>> Control.Lens.Internal.Deque.null empty -- True -- -- >>> Control.Lens.Internal.Deque.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 = 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 = foldr cons ys xs | otherwise = 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 = foldr cons ys xs | otherwise = 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 = pure {-# 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 = foldr cons ys xs | otherwise = foldl snoc xs ys {-# INLINE (<>) #-} instance Monoid (Deque a) where mempty = BD 0 [] 0 [] {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend xs ys | size xs < size ys = foldr cons ys xs | otherwise = foldl snoc xs ys {-# INLINE mappend #-} #endif -- | 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 Cons (Deque a) (Deque b) a b where _Cons = prism (\(x,BD lf f lr r) -> check (lf + 1) (x : f) lr r) $ \ (BD lf f lr r) -> if lf + lr == 0 then Left empty else Right $ case f of [] -> case r of y:_ -> (y, empty) [] -> error "Control.Lens.Internal.Deque._Cons: Internal check failed" (x:xs) -> (x, check (lf - 1) xs lr r) {-# INLINE _Cons #-} instance Snoc (Deque a) (Deque b) a b where _Snoc = prism (\(BD lf f lr r,x) -> check lf f (lr + 1) (x : r)) $ \ (BD lf f lr r) -> if lf + lr == 0 then Left empty else Right $ case r of [] -> case f of y:_ -> (empty, y) [] -> error "Control.Lens.Internal.Deque._Snoc: Internal check failed" (x:xs) -> (check lf f (lr - 1) xs, x) {-# INLINE _Snoc #-} lens-5.2.3/src/Control/Lens/Internal/Doctest.hs0000644000000000000000000000410707346545000017502 0ustar0000000000000000-- | This module exists for the sole purpose of redefining the 'head' and 'tail' -- functions (which are normally provided by the 'Prelude') so that they can be -- used in the doctests of 'Data.Data.Lens'. -- -- The 'head' and 'tail' functions are partial, and as of GHC 9.8, there is a -- @-Wx-partial@ warning (implied by @-Wall@) that triggers any time you use -- either of these functions. This is a fairly reasonable default in most -- settings, but there are a handful of doctests in 'Data.Data.Lens' that do in -- fact rely on 'head' and 'tail' being partial functions. These doctests -- demonstrate that various functions in 'Data.Data.Lens' can recover from -- exceptions that are thrown due to partiality (see, for instance, the @upon@ -- function). -- -- One possible workaround would be to disable @-Wx-partial@. We don't want to -- disable the warning for /all/ code in @lens@, however—we only want to -- disable it for a particular group of doctests. It is rather tricky to achieve -- this level of granularity, unfortunately. This is because tools like -- @cabal-docspec@ rely on GHCi to work, and the statefulness of GHCi's @:set@ -- command means that disabling @-Wx-partial@ might leak into other modules' -- doctests, which we don't want. -- -- Instead, we opt to redefine our own versions of 'head' and 'tail' here, which -- do not trigger any @-Wx-partial@ warnings, and use them in the -- 'Data.Data.Lens' doctests. This has no impact on anyone reading the doctests, -- as these functions will look indistinguishable from the 'head' and 'tail' -- functions in the 'Prelude'. One consequence of this design is that we must -- export the 'Control.Lens.Internal.Doctest' module, as GHCi (and therefore -- @cabal-docspec@) won't be able to import it otherwise. Despite this technical -- oddity, this module should be thought of as internal to @lens@. module Control.Lens.Internal.Doctest ( head , tail ) where import Prelude hiding (head, tail) head :: [a] -> a head (x:_) = x head [] = error "head: empty list" tail :: [a] -> [a] tail (_:xs) = xs tail [] = error "tail: empty list" lens-5.2.3/src/Control/Lens/Internal/Exception.hs0000644000000000000000000002032707346545000020035 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Exception -- Copyright : (C) 2013-2016 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.Catch as Catch import Data.Kind import Data.Monoid import Data.Proxy import Data.Reflection import Data.Typeable ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------ -- | Both @exceptions@ and "Control.Exception" provide a 'Handler' type. -- -- This lets us write combinators to build handlers that are agnostic about the choice of -- which of these they use. class Handleable e (m :: Type -> Type) (h :: Type -> Type) | 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 'Catch.Handler' type provided by @Control.Monad.Catch@: -- -- @ -- 'handler' :: 'Getter' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r -- 'handler' :: 'Fold' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r -- 'handler' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r -- 'handler' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r -- @ -- -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@: -- -- @ -- '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 :: Typeable a => Getting (First a) e a -> (a -> m r) -> h r -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Prism.Prism' (or any 'Getter', really). -- that ignores its input and just recovers with the stated monadic action. -- -- @ -- '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 'Catch.Handler' type provided by @Control.Monad.Catch@: -- -- @ -- 'handler_' :: 'Getter' 'SomeException' a -> m r -> 'Catch.Handler' m r -- 'handler_' :: 'Fold' 'SomeException' a -> m r -> 'Catch.Handler' m r -- 'handler_' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> m r -> 'Catch.Handler' m r -- 'handler_' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> m r -> 'Catch.Handler' m r -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> m r -> 'Catch.Handler' m r -- @ -- -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@: -- -- @ -- '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_ :: Typeable a => Getting (First a) e a -> m r -> h r handler_ l = handler l . const {-# INLINE handler_ #-} instance Handleable SomeException IO Exception.Handler where handler = handlerIO instance Typeable m => Handleable SomeException m (Catch.Handler m) where handler = handlerCatchIO handlerIO :: forall a r. Typeable a => Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r handlerIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a) handlerCatchIO :: forall m a r. (Typeable a, Typeable m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r handlerCatchIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Catch.Handler (\(Handling a :: Handling a s m) -> f a) ------------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------------ -- | There was an 'Exception' caused by abusing the internals of a 'Handler'. data HandlingException = HandlingException deriving Show 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 :: Type -> Type) = Handling a type role Handling representational nominal nominal -- 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) , Typeable a, Typeable s , Typeable m ) => Exception (Handling a (s :: Type) m) where toException _ = SomeException HandlingException {-# INLINE toException #-} fromException = fmap Handling . reflect (Proxy :: Proxy s) {-# INLINE fromException #-} lens-5.2.3/src/Control/Lens/Internal/FieldTH.hs0000644000000000000000000006354207346545000017364 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #else {-# LANGUAGE TemplateHaskell #-} #endif #ifdef TRUSTWORTHY # if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-} # else {-# LANGUAGE Trustworthy #-} # endif #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.FieldTH -- Copyright : (C) 2014-2016 Edward Kmett, (C) 2014 Eric Mertens -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.Internal.FieldTH ( LensRules(..) , FieldNamer , DefName(..) , ClassyNamer , makeFieldOptics , makeFieldOpticsForDec , makeFieldOpticsForDec' , HasFieldClasses ) where import Prelude () import Control.Lens.At import Control.Lens.Fold import Control.Lens.Indexed import Control.Lens.Internal.TH import Control.Lens.Internal.Prelude import Control.Lens.Lens import Control.Lens.Plated import Control.Lens.Prism import Control.Lens.Setter import Control.Lens.Getter import Control.Lens.Tuple import Control.Lens.Traversal import Control.Monad import Control.Monad.State import Language.Haskell.TH.Lens import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Data.Maybe (fromMaybe,isJust,maybeToList) import Data.List (nub) import Data.Either (partitionEithers) import Data.Semigroup (Any (..)) import Data.Set.Lens import Data.Map ( Map ) import Data.Set ( Set ) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Traversable as T ------------------------------------------------------------------------ -- Field generation entry point ------------------------------------------------------------------------ -- | Compute the field optics for the type identified by the given type name. -- Lenses will be computed when possible, Traversals otherwise. makeFieldOptics :: LensRules -> Name -> DecsQ makeFieldOptics rules = (`evalStateT` Set.empty) . makeFieldOpticsForDatatype rules <=< D.reifyDatatype makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ makeFieldOpticsForDec rules = (`evalStateT` Set.empty) . makeFieldOpticsForDec' rules makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec] makeFieldOpticsForDec' rules = makeFieldOpticsForDatatype rules <=< lift . D.normalizeDec -- | Compute the field optics for a deconstructed datatype Dec -- When possible build an Iso otherwise build one optic per field. makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec] makeFieldOpticsForDatatype rules info = do perDef <- lift $ do fieldCons <- traverse normalizeConstructor cons let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons let defCons = over normFieldLabels (expandName allFields) fieldCons allDefs = setOf (normFieldLabels . folded . _1) defCons T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of Just (className, methodName) -> makeClassyDriver rules className methodName s defs Nothing -> do decss <- traverse (makeFieldOptic rules) defs return (concat decss) where tyName = D.datatypeName info s = datatypeTypeKinded info cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b normFieldLabels = traverse . _2 . traverse . _1 -- Map a (possibly missing) field's name to zero-to-many optic definitions expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)] expandName allFields mName = (\x -> (x, mName)) <$> (maybeToList mName >>= _fieldToDef rules tyName allFields) -- | Normalized the Con type into a uniform positional representation, -- eliminating the variance between records, infix constructors, and normal -- constructors. normalizeConstructor :: D.ConstructorInfo -> Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type normalizeConstructor con = return (D.constructorName con, zipWith checkForExistentials fieldNames (D.constructorFields con)) where fieldNames = case D.constructorVariant con of D.RecordConstructor xs -> fmap Just xs D.NormalConstructor -> repeat Nothing D.InfixConstructor -> repeat Nothing -- Fields mentioning existentially quantified types are not -- elligible for TH generated optics. checkForExistentials _ fieldtype | any (\tv -> D.tvName tv `Set.member` used) unallowable = (Nothing, fieldtype) where used = setOf typeVars fieldtype unallowable = D.constructorVars con checkForExistentials fieldname fieldtype = (fieldname, fieldtype) data OpticType = GetterType | LensType | IsoType -- | Compute the positional location of the fields involved in -- each constructor for a given optic definition as well as the -- type of clauses to generate and the type to annotate the declaration -- with. buildScaffold :: LensRules -> Type {- ^ outer type -} -> [(Name, [([(DefName, Maybe Name)], Type)])] {- ^ normalized constructors -} -> DefName {- ^ target definition -} -> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]) {- ^ optic type, definition type, field count, target fields -} buildScaffold rules s cons defName = do (s',t,a,b) <- buildStab s (concatMap snd (consForDef <&> _2 . mapped . _Right %~ snd)) let defType | Just (_,cx,a') <- preview _ForallT a = let optic | lensCase = getterTypeName | otherwise = foldTypeName in OpticSa cx optic s' a' -- Getter and Fold are always simple | not (_allowUpdates rules) = let optic | lensCase = getterTypeName | otherwise = foldTypeName in OpticSa [] optic s' a -- Generate simple Lens and Traversal where possible | _simpleLenses rules || s' == t && a == b = let optic | isoCase && _allowIsos rules = iso'TypeName | lensCase = lens'TypeName | otherwise = traversal'TypeName in OpticSa [] optic s' a -- Generate type-changing Lens and Traversal otherwise | otherwise = let optic | isoCase && _allowIsos rules = isoTypeName | lensCase = lensTypeName | otherwise = traversalTypeName in OpticStab optic s' t a b opticType | has _ForallT a = GetterType | not (_allowUpdates rules) = GetterType | isoCase = IsoType | otherwise = LensType return (opticType, defType, scaffolds) where consForDef :: [(Name, [Either Type (Maybe Name, Type)])] consForDef = over (mapped . _2 . mapped) categorize cons scaffolds :: [(Name, Int, [(Maybe Name, Int)])] scaffolds = [ (n, length ts, (\(a, b) -> (b, a)) <$> ts ^@.. folded <. _Right . _1) | (n,ts) <- consForDef ] -- Right: types for this definition -- Left : other types categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type) categorize (defNames, t) = case lookup defName defNames of Just c -> Right (c, t) Nothing -> Left t lensCase :: Bool lensCase = all (\x -> lengthOf (_2 . folded . _Right) x == 1) consForDef isoCase :: Bool isoCase = case scaffolds of [(_,1,[(_, 0)])] -> True _ -> False data OpticStab = OpticStab Name Type Type Type Type | OpticSa Cxt Name Type Type stabToType :: OpticStab -> Type stabToType (OpticStab c s t a b) = quantifyType [] (c `conAppsT` [s,t,a,b]) stabToType (OpticSa cx c s a ) = quantifyType cx (c `conAppsT` [s,a]) stabToContext :: OpticStab -> Cxt stabToContext OpticStab{} = [] stabToContext (OpticSa cx _ _ _) = cx stabToOptic :: OpticStab -> Name stabToOptic (OpticStab c _ _ _ _) = c stabToOptic (OpticSa _ c _ _) = c stabToS :: OpticStab -> Type stabToS (OpticStab _ s _ _ _) = s stabToS (OpticSa _ _ s _) = s stabToA :: OpticStab -> Type stabToA (OpticStab _ _ _ a _) = a stabToA (OpticSa _ _ _ a) = a -- | Compute the s t a b types given the outer type 's' and the -- categorized field types. Left for fixed and Right for visited. -- These types are "raw" and will be packaged into an 'OpticStab' -- shortly after creation. buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type) buildStab s categorizedFields = do (subA,a) <- unifyTypes targetFields let s' = applyTypeSubst subA s -- compute possible type changes sub <- T.sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars) let (t,b) = over both (substTypeVars sub) (s',a) return (s',t,a,b) where (fixedFields, targetFields) = partitionEithers categorizedFields fixedTypeVars, unfixedTypeVars :: Set Name fixedTypeVars = closeOverKinds $ setOf typeVars fixedFields unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars -- Compute the kind variables that appear in the kind of a type variable -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a -- type variable binder lacks an explicit kind annotation, this -- conservatively assumes that there are no kind variables. For example, -- @kindVarsOfTvb (y) = (y, {})@. kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name) kindVarsOfTvb = D.elimTV (\n -> (n, Set.empty)) (\n k -> (n, setOf typeVars k)) -- For each type variable name that appears in @s@, map to the kind variables -- that appear in that type variable's kind. sKindVarMap :: Map Name (Set Name) sKindVarMap = Map.fromList $ map kindVarsOfTvb $ D.freeVariablesWellScoped [s] lookupSKindVars :: Name -> Set Name lookupSKindVars n = fromMaybe Set.empty $ Map.lookup n sKindVarMap -- Consider this example (adapted from #972): -- -- data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int } -- $(makeLenses ''Dart) -- -- When generating a Lens for `direction`, the type variable `s` should be -- fixed. But note that (s :: k), and as a result, the kind variable `k` -- needs to be fixed as well. This is because a type like this would be -- ill kinded: -- -- direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction -- -- However, only `s` is mentioned syntactically in the type of `_arc`, so we -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this -- with `closeOverKinds`, which does the following: -- -- 1. Use freeVariablesWellScoped to compute the free type variables of -- `Dart (s :: k)`, which gives us `(s :: k)`. -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up -- the kind variables in the type variable's kind. In the case of `s`, -- the only kind variable is `k`. -- 3. Add these kind variables to the set of fixed type variables. closeOverKinds :: Set Name -> Set Name closeOverKinds st = foldl' Set.union Set.empty (Set.map lookupSKindVars st) `Set.union` st -- | Build the signature and definition for a single field optic. -- In the case of a singleton constructor irrefutable matches are -- used to enable the resulting lenses to be used on a bottom value. makeFieldOptic :: LensRules -> (DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])) -> HasFieldClasses [Dec] makeFieldOptic rules (defName, (opticType, defType, cons)) = do locals <- get addName lift $ do cls <- mkCls locals T.sequenceA (cls ++ sig ++ def) where mkCls locals = case defName of MethodName c n | _generateClasses rules -> do classExists <- isJust <$> lookupTypeName (show c) return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n]) _ -> return [] addName = case defName of MethodName c _ -> addFieldClassName c _ -> return () sig = case defName of _ | not (_generateSigs rules) -> [] TopName n -> [sigD n (return (stabToType defType))] MethodName{} -> [] fun n = funD n clauses : inlinePragma n def = case defName of TopName n -> fun n MethodName c n -> [makeFieldInstance defType c (fun n)] clauses = makeFieldClauses rules opticType cons ------------------------------------------------------------------------ -- Classy class generator ------------------------------------------------------------------------ makeClassyDriver :: LensRules -> Name -> Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> HasFieldClasses [Dec] makeClassyDriver rules className methodName s defs = T.sequenceA (cls ++ inst) where cls | _generateClasses rules = [lift $ makeClassyClass className methodName s defs] | otherwise = [] inst = [makeClassyInstance rules className methodName s defs] makeClassyClass :: Name -> Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> DecQ makeClassyClass className methodName s defs = do let ss = map (stabToS . view (_2 . _2)) defs (sub,s') <- unifyTypes (s : ss) c <- newName "c" let vars = D.changeTVFlags bndrReq $ D.freeVariablesWellScoped [s'] varNames = map D.tvName vars fd | null vars = [] | otherwise = [FunDep [c] varNames] classD (cxt[]) className (D.plainTV c:vars) fd $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s'])) : concat [ [sigD defName (return ty) ,valD (varP defName) (normalB body) [] ] ++ inlinePragma defName | (TopName defName, (_, stab, _)) <- defs , let body = appsE [varE composeValName, varE methodName, varE defName] , let ty = quantifyType' (Set.fromList (c:varNames)) (stabToContext stab) $ stabToOptic stab `conAppsT` [VarT c, applyTypeSubst sub (stabToA stab)] ] makeClassyInstance :: LensRules -> Name -> Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> HasFieldClasses Dec makeClassyInstance rules className methodName s defs = do methodss <- traverse (makeFieldOptic rules') defs lift $ instanceD (cxt[]) (return instanceHead) $ valD (varP methodName) (normalB (varE idValName)) [] : map return (concat methodss) where instanceHead = className `conAppsT` (s : map tvbToType vars) vars = D.freeVariablesWellScoped [s] rules' = rules { _generateSigs = False , _generateClasses = False } ------------------------------------------------------------------------ -- Field class generation ------------------------------------------------------------------------ makeFieldClass :: OpticStab -> Name -> Name -> DecQ makeFieldClass defType className methodName = classD (cxt []) className [D.plainTV s, D.plainTV a] [FunDep [s] [a]] [sigD methodName (return methodType)] where methodType = quantifyType' (Set.fromList [s,a]) (stabToContext defType) $ stabToOptic defType `conAppsT` [VarT s,VarT a] s = mkName "s" a = mkName "a" -- | Build an instance for a field. If the field’s type contains any type -- families, will produce an equality constraint to avoid a type family -- application in the instance head. makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ makeFieldInstance defType className decs = containsTypeFamilies a >>= pickInstanceDec where s = stabToS defType a = stabToA defType containsTypeFamilies = go <=< D.resolveTypeSynonyms where go :: Type -> Q Bool go (ConT nm) = -- Note that the call to `reify` can fail if `nm` is not yet defined. -- (This can actually happen if `nm` is declared in a Template Haskell -- quote.) If this fails, there is no way to tell if the type contains -- type families, so we recover and conservatively assume that is does not -- contain any. recover (pure False) (has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm) go ty = or <$> traverse go (ty ^.. plate) -- We want to catch type families, but not *data* families. See #799. _TypeFamilyD :: Getting Any Dec () _TypeFamilyD = _OpenTypeFamilyD.united <> _ClosedTypeFamilyD.united pickInstanceDec hasFamilies | hasFamilies = do placeholder <- VarT <$> newName "a" mkInstanceDec [return (D.equalPred placeholder a)] [s, placeholder] | otherwise = mkInstanceDec [] [s, a] mkInstanceDec context headTys = instanceD (cxt context) (return (className `conAppsT` headTys)) decs ------------------------------------------------------------------------ -- Optic clause generators ------------------------------------------------------------------------ makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ] makeFieldClauses rules opticType cons = case opticType of IsoType -> [ makeIsoClause conName | (conName, _, _) <- cons ] GetterType -> [ makeGetterClause conName fieldCount (snd <$> fields) | (conName, fieldCount, fields) <- cons ] LensType -> [ makeFieldOpticClause conName fieldCount fields irref recSyn | (conName, fieldCount, fields) <- cons ] where irref = _lazyPatterns rules && length cons == 1 recSyn = _recordSyntax rules && length cons == 1 -- | Construct an optic clause that returns an unmodified value -- given a constructor name and the number of fields on that -- constructor. makePureClause :: Name -> Int -> ClauseQ makePureClause conName fieldCount = do xs <- newNames "x" fieldCount -- clause: _ (Con x1..xn) = pure (Con x1..xn) clause [wildP, conP conName (map varP xs)] (normalB (appE (varE pureValName) (appsE (conE conName : map varE xs)))) [] -- | Construct an optic clause suitable for a Getter or Fold -- by visited the fields identified by their 0 indexed positions makeGetterClause :: Name -> Int -> [Int] -> ClauseQ makeGetterClause conName fieldCount [] = makePureClause conName fieldCount makeGetterClause conName fieldCount fields = do f <- newName "f" xs <- newNames "x" (length fields) xs' <- case xs of (x:xs') -> pure (x :| xs') [] -> fail "makeGetterClause: Internal check failed" let pats (i:is) (y:ys) | i `elem` fields = varP y : pats is ys | otherwise = wildP : pats is (y:ys) pats is _ = map (const wildP) is (fx :| fxs) = fmap (appE (varE f) . varE) xs' body = foldl (\a b -> appsE [varE apValName, a, b]) (appE (varE phantomValName) fx) fxs -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn clause [varP f, conP conName (pats [0..fieldCount - 1] xs)] (normalB body) [] -- | Build a clause that updates the field at the given indexes -- When irref is 'True' the value with me matched with an irrefutable -- pattern. This is suitable for Lens and Traversal construction makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ makeFieldOpticClause conName fieldCount [] _ _ = makePureClause conName fieldCount makeFieldOpticClause _ _ [(Just fieldName, _)] _ True = do f <- newName "f" r <- newName "r" x <- newName "x" let body = appsE [ [| fmap |] , lamE [varP x] (recUpdE (varE r) [(,) fieldName <$> varE x]) , varE f `appE` (varE fieldName `appE` varE r) ] clause [varP f, varP r] (normalB body) [] makeFieldOpticClause conName fieldCount ((_, field):fieldsWithNames) irref _ = do f <- newName "f" xs <- newNames "x" fieldCount ys <- newNames "y" (1 + length fieldsWithNames) let fields = snd <$> fieldsWithNames xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) mkFx i = appE (varE f) (varE (xs !! i)) body0 = appsE [ varE fmapValName , lamE (map varP ys) (appsE (conE conName : map varE xs')) , mkFx field ] body = foldl (\a b -> appsE [varE apValName, a, mkFx b]) body0 fields let wrap = if irref then tildeP else id clause [varP f, wrap (conP conName (map varP xs))] (normalB body) [] -- | Build a clause that constructs an Iso makeIsoClause :: Name -> ClauseQ makeIsoClause conName = clause [] (normalB (appsE [varE isoValName, destruct, construct])) [] where destruct = do x <- newName "x" lam1E (conP conName [varP x]) (varE x) construct = conE conName ------------------------------------------------------------------------ -- Unification logic ------------------------------------------------------------------------ -- The field-oriented optic generation supports incorporating fields -- with distinct but unifiable types into a single definition. -- | Unify the given list of types, if possible, and return the -- substitution used to unify the types for unifying the outer -- type when building a definition's type signature. unifyTypes :: [Type] -> Q (Map Name Type, Type) unifyTypes (x:xs) = foldM (uncurry unify1) (Map.empty, x) xs unifyTypes [] = fail "unifyTypes: Bug: Unexpected empty list" -- | Attempt to unify two given types using a running substitution unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type) unify1 sub (VarT x) y | Just r <- Map.lookup x sub = unify1 sub r y unify1 sub x (VarT y) | Just r <- Map.lookup y sub = unify1 sub x r unify1 sub x y | x == y = return (sub, x) unify1 sub (AppT f1 x1) (AppT f2 x2) = do (sub1, f) <- unify1 sub f1 f2 (sub2, x) <- unify1 sub1 x1 x2 return (sub2, AppT (applyTypeSubst sub2 f) x) unify1 sub x (VarT y) | elemOf typeVars y (applyTypeSubst sub x) = fail "Failed to unify types: occurs check" | otherwise = return (Map.insert y x sub, x) unify1 sub (VarT x) y = unify1 sub y (VarT x) -- TODO: Unify contexts unify1 sub (ForallT v1 [] t1) (ForallT v2 [] t2) = -- This approach works out because by the time this code runs -- all of the type variables have been renamed. No risk of shadowing. do (sub1,t) <- unify1 sub t1 t2 v <- fmap nub (traverse (limitedSubst sub1) (v1++v2)) return (sub1, ForallT v [] t) unify1 _ x y = fail ("Failed to unify types: " ++ show (x,y)) -- | Perform a limited substitution on type variables. This is used -- when unifying rank-2 fields when trying to achieve a Getter or Fold. limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec limitedSubst sub tv | Just r <- Map.lookup (D.tvName tv) sub = case r of VarT m -> limitedSubst sub (D.mapTVName (const m) tv) _ -> fail "Unable to unify exotic higher-rank type" | otherwise = return tv -- | Apply a substitution to a type. This is used after unifying -- the types of the fields in unifyTypes. applyTypeSubst :: Map Name Type -> Type -> Type applyTypeSubst sub = rewrite aux where aux (VarT n) = Map.lookup n sub aux _ = Nothing ------------------------------------------------------------------------ -- Field generation parameters ------------------------------------------------------------------------ -- | Rules to construct lenses for data fields. data LensRules = LensRules { _simpleLenses :: Bool , _generateSigs :: Bool , _generateClasses :: Bool , _allowIsos :: Bool , _allowUpdates :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold) , _lazyPatterns :: Bool , _recordSyntax :: Bool , _fieldToDef :: FieldNamer -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names , _classyLenses :: ClassyNamer -- type name to class name and top method } -- | The rule to create function names of lenses for data fields. -- -- Although it's sometimes useful, you won't need the first two -- arguments most of the time. type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for. -> [Name] -- ^ Names of all fields (including the field being named) in the data type. -> Name -- ^ Name of the field being named. -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field. -- | Name to give to generated field optics. data DefName = TopName Name -- ^ Simple top-level definition name | MethodName Name Name -- ^ makeFields-style class name and method name deriving (Show, Eq, Ord) -- | The optional rule to create a class and method around a -- monomorphic data type. If this naming convention is provided, it -- generates a "classy" lens. type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for. -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively. -- | Tracks the field class 'Name's that have been created so far. We consult -- these so that we may avoid creating duplicate classes. -- See #643 for more information. type HasFieldClasses = StateT (Set Name) Q addFieldClassName :: Name -> HasFieldClasses () addFieldClassName n = modify $ Set.insert n lens-5.2.3/src/Control/Lens/Internal/Fold.hs0000644000000000000000000001533607346545000016767 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Fold -- Copyright : (C) 2012-2016 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(..) , TraversedF(..) , Sequenced(..) , Leftmost(..), getLeftmost , Rightmost(..), getRightmost , ReifiedMonoid(..) -- * Semigroups for folding , NonEmptyDList(..) ) where import Prelude () import Control.Lens.Internal.Getter import Control.Lens.Internal.Prelude import Data.Functor.Bind import Data.Maybe (fromMaybe) import Data.Reflection import qualified Data.List.NonEmpty as NonEmpty ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------ -- | A 'Monoid' for a 'Contravariant' 'Applicative'. newtype Folding f a = Folding { getFolding :: f a } instance (Contravariant f, Applicative 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 #-} #if !(MIN_VERSION_base(4,11,0)) Folding fr `mappend` Folding fs = Folding (fr *> fs) {-# INLINE mappend #-} #endif ------------------------------------------------------------------------------ -- 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 } -- See 4.16 Changelog entry for the explanation of "why not Apply f =>"? instance Applicative 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 #-} #if !(MIN_VERSION_base(4,11,0)) Traversed ma `mappend` Traversed mb = Traversed (ma *> mb) {-# INLINE mappend #-} #endif ------------------------------------------------------------------------------ -- TraversedF ------------------------------------------------------------------------------ -- | Used internally by 'Control.Lens.Fold.traverse1Of_' and the like. -- -- @since 4.16 newtype TraversedF a f = TraversedF { getTraversedF :: f a } instance Apply f => Semigroup (TraversedF a f) where TraversedF ma <> TraversedF mb = TraversedF (ma .> mb) {-# INLINE (<>) #-} instance (Apply f, Applicative f) => Monoid (TraversedF a f) where mempty = TraversedF (pure (error "TraversedF: value used")) {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) TraversedF ma `mappend` TraversedF mb = TraversedF (ma *> mb) {-# INLINE mappend #-} #endif ------------------------------------------------------------------------------ -- Sequenced ------------------------------------------------------------------------------ -- | Used internally by 'Control.Lens.Traversal.mapM_' and the like. -- -- The argument 'a' of the result should not be used! -- -- See 4.16 Changelog entry for the explanation of "why not Apply f =>"? newtype Sequenced a m = Sequenced { getSequenced :: m a } instance Monad 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 #-} #if !(MIN_VERSION_base(4,11,0)) Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) {-# INLINE mappend #-} #endif ------------------------------------------------------------------------------ -- NonEmptyDList ------------------------------------------------------------------------------ newtype NonEmptyDList a = NonEmptyDList { getNonEmptyDList :: [a] -> NonEmpty.NonEmpty a } instance Semigroup (NonEmptyDList a) where NonEmptyDList f <> NonEmptyDList g = NonEmptyDList (f . NonEmpty.toList . g) ------------------------------------------------------------------------------ -- Leftmost and Rightmost ------------------------------------------------------------------------------ -- | Used for 'Control.Lens.Fold.firstOf'. data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) instance Semigroup (Leftmost a) where 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 _ -> 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' instance Monoid (Leftmost a) where mempty = LPure {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) {-# INLINE mappend #-} #endif -- | 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 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 _ -> 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' instance Monoid (Rightmost a) where mempty = RPure {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) {-# INLINE mappend #-} #endif -- | 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-5.2.3/src/Control/Lens/Internal/Getter.hs0000644000000000000000000001034407346545000017327 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Getter -- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Getter ( noEffect , AlongsideLeft(..) , AlongsideRight(..) ) where import Prelude () import Control.Lens.Internal.Prelude import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Semigroup.Foldable import Data.Semigroup.Traversable -- | The 'mempty' equivalent for a 'Contravariant' 'Applicative' 'Functor'. noEffect :: (Contravariant f, Applicative f) => f a noEffect = phantom $ pure () {-# INLINE noEffect #-} newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) } deriving instance Show (f (a, b)) => Show (AlongsideLeft f b a) deriving instance Read (f (a, b)) => Read (AlongsideLeft f b a) instance Functor f => Functor (AlongsideLeft f b) where fmap f = AlongsideLeft . fmap (first f) . getAlongsideLeft {-# INLINE fmap #-} instance Contravariant f => Contravariant (AlongsideLeft f b) where contramap f = AlongsideLeft . contramap (first f) . getAlongsideLeft {-# INLINE contramap #-} instance Foldable f => Foldable (AlongsideLeft f b) where foldMap f = foldMap (f . fst) . getAlongsideLeft {-# INLINE foldMap #-} instance Traversable f => Traversable (AlongsideLeft f b) where traverse f (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse f pure) as {-# INLINE traverse #-} instance Foldable1 f => Foldable1 (AlongsideLeft f b) where foldMap1 f = foldMap1 (f . fst) . getAlongsideLeft {-# INLINE foldMap1 #-} instance Traversable1 f => Traversable1 (AlongsideLeft f b) where traverse1 f (AlongsideLeft as) = AlongsideLeft <$> traverse1 (\(a,b) -> flip (,) b <$> f a) as {-# INLINE traverse1 #-} instance Functor f => Bifunctor (AlongsideLeft f) where bimap f g = AlongsideLeft . fmap (bimap g f) . getAlongsideLeft {-# INLINE bimap #-} instance Foldable f => Bifoldable (AlongsideLeft f) where bifoldMap f g = foldMap (bifoldMap g f) . getAlongsideLeft {-# INLINE bifoldMap #-} instance Traversable f => Bitraversable (AlongsideLeft f) where bitraverse f g (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse g f) as {-# INLINE bitraverse #-} newtype AlongsideRight f a b = AlongsideRight { getAlongsideRight :: f (a, b) } deriving instance Show (f (a, b)) => Show (AlongsideRight f a b) deriving instance Read (f (a, b)) => Read (AlongsideRight f a b) instance Functor f => Functor (AlongsideRight f a) where fmap f (AlongsideRight x) = AlongsideRight (fmap (second f) x) {-# INLINE fmap #-} instance Contravariant f => Contravariant (AlongsideRight f a) where contramap f (AlongsideRight x) = AlongsideRight (contramap (second f) x) {-# INLINE contramap #-} instance Foldable f => Foldable (AlongsideRight f a) where foldMap f = foldMap (f . snd) . getAlongsideRight {-# INLINE foldMap #-} instance Traversable f => Traversable (AlongsideRight f a) where traverse f (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse pure f) as {-# INLINE traverse #-} instance Foldable1 f => Foldable1 (AlongsideRight f a) where foldMap1 f = foldMap1 (f . snd) . getAlongsideRight {-# INLINE foldMap1 #-} instance Traversable1 f => Traversable1 (AlongsideRight f a) where traverse1 f (AlongsideRight as) = AlongsideRight <$> traverse1 (\(a,b) -> (,) a <$> f b) as {-# INLINE traverse1 #-} instance Functor f => Bifunctor (AlongsideRight f) where bimap f g = AlongsideRight . fmap (bimap f g) . getAlongsideRight {-# INLINE bimap #-} instance Foldable f => Bifoldable (AlongsideRight f) where bifoldMap f g = foldMap (bifoldMap f g) . getAlongsideRight {-# INLINE bifoldMap #-} instance Traversable f => Bitraversable (AlongsideRight f) where bitraverse f g (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse f g) as {-# INLINE bitraverse #-} lens-5.2.3/src/Control/Lens/Internal/Indexed.hs0000644000000000000000000003324007346545000017455 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Indexed -- Copyright : (C) 2012-2016 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 -- * Converting to Folds , withIndex , asIndex ) where import Prelude () import Control.Arrow as Arrow import qualified Control.Category as C import Control.Comonad import Control.Lens.Internal.Prelude import Control.Lens.Internal.Instances () import Control.Monad.Fix import Data.Distributive import Data.Functor.Bind import Data.Int import Data.Profunctor.Closed import Data.Profunctor.Rep -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens -- >>> import Data.Semigroup (Semigroup (..)) -- ------------------------------------------------------------------------------ -- 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) , Costrong p, ArrowLoop p, ArrowApply p, ArrowChoice p, Closed 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 . sieve {-# 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 = pure {-# 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 #-} (.#) ibc _ = coerce ibc {-# INLINE (.#) #-} (#.) _ = coerce {-# INLINE (#.) #-} instance Closed (Indexed i) where closed (Indexed iab) = Indexed $ \i xa x -> iab i (xa x) instance Costrong (Indexed i) where unfirst (Indexed iadbd) = Indexed $ \i a -> let (b, d) = iadbd i (a, d) in b instance Sieve (Indexed i) ((->) i) where sieve = flip . runIndexed {-# INLINE sieve #-} instance Representable (Indexed i) where type Rep (Indexed i) = (->) i tabulate = Indexed . flip {-# INLINE tabulate #-} instance Cosieve (Indexed i) ((,) i) where cosieve = uncurry . runIndexed {-# INLINE cosieve #-} instance Corepresentable (Indexed i) where type Corep (Indexed i) = (,) i cotabulate = Indexed . curry {-# INLINE cotabulate #-} instance Choice (Indexed i) where right' = right {-# INLINE right' #-} instance Strong (Indexed i) where second' = second {-# INLINE second' #-} instance C.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 #-} instance Semigroup (f a) => Semigroup (Indexing f a) where Indexing mx <> Indexing my = Indexing $ \i -> case mx i of (j, x) -> case my j of ~(k, y) -> (k, x <> y) {-# INLINE (<>) #-} -- | -- -- >>> "cat" ^@.. (folded <> folded) -- [(0,'c'),(1,'a'),(2,'t'),(0,'c'),(1,'a'),(2,'t')] -- -- >>> "cat" ^@.. indexing (folded <> folded) -- [(0,'c'),(1,'a'),(2,'t'),(3,'c'),(4,'a'),(5,'t')] instance Monoid (f a) => Monoid (Indexing f a) where mempty = Indexing $ \i -> (i, mempty) {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend (Indexing mx) (Indexing my) = Indexing $ \i -> case mx i of (j, x) -> case my j of ~(k, y) -> (k, mappend x y) {-# INLINE mappend #-} #endif -- | 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.Over' 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.Over' p f s t a b@ indexing64 :: Indexable Int64 p => ((a -> Indexing64 f b) -> s -> Indexing64 f t) -> p a (f b) -> s -> f t indexing64 l iafb s = snd $ runIndexing64 (l (\a -> Indexing64 (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 {-# INLINE indexing64 #-} ------------------------------------------------------------------------------- -- 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. -- -- >>> [10, 20, 30] ^.. ifolded . withIndex -- [(0,10),(1,20),(2,30)] -- -- >>> [10, 20, 30] ^.. ifolded . withIndex . alongside negated (re _Show) -- [(0,"10"),(-1,"20"),(-2,"30")] -- withIndex :: (Indexable i p, Functor f) => p (i, s) (f (j, t)) -> Indexed i s (f 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) => p i (f i) -> Indexed i s (f s) asIndex f = Indexed $ \i _ -> phantom (indexed f i i) {-# INLINE asIndex #-} lens-5.2.3/src/Control/Lens/Internal/Instances.hs0000644000000000000000000000125607346545000020026 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Instances -- Copyright : (C) 2012-2016 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. These have moved to @semigroupoids@ as of 4.2. ---------------------------------------------------------------------------- module Control.Lens.Internal.Instances () where import Data.Orphans () import Data.Traversable.Instances () lens-5.2.3/src/Control/Lens/Internal/Iso.hs0000644000000000000000000000624607346545000016635 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Iso -- Copyright : (C) 2012-2016 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 import Data.Profunctor.Unsafe import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB import Data.Coerce import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT 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 qualified Data.Vector.Unboxed as Unbox import Data.Vector.Unboxed (Unbox) import qualified Data.Sequence as Seq import Data.Sequence (Seq) import Foreign.Storable (Storable) ------------------------------------------------------------------------------ -- 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 #-} (#.) _ = coerce {-# INLINE (#.) #-} (.#) p _ = coerce p ------------------------------------------------------------------------------ -- 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 (NonEmpty.NonEmpty a) where reversing = NonEmpty.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-5.2.3/src/Control/Lens/Internal/Level.hs0000644000000000000000000001454007346545000017146 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Level -- Copyright : (C) 2012-2016 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 Prelude () import Control.Lens.Internal.Prelude import Data.Functor.Apply import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- 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 #-} 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 #-} ------------------------------------------------------------------------------ -- 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 #-} #if !(MIN_VERSION_base(4,11,0)) 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 #-} #endif -- | 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-5.2.3/src/Control/Lens/Internal/List.hs0000644000000000000000000000430707346545000017012 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.List -- Copyright : (C) 2014-2016 Edward Kmett and Eric Mertens -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- -- This module provides utility functions on lists used by the library -- implementation. ------------------------------------------------------------------------------- module Control.Lens.Internal.List ( ordinalNub , stripSuffix ) where import Control.Monad (guard) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet --- $setup --- >>> :set -XNoOverloadedStrings --- >>> import Control.Lens.Internal.List -- | Return the the subset of given ordinals within a given bound -- and in order of the first occurrence seen. -- -- Bound: @0 <= x < l@ -- -- >>> ordinalNub 3 [-1,2,1,4,2,3] -- [2,1] ordinalNub :: Int {- ^ strict upper bound -} -> [Int] {- ^ ordinals -} -> [Int] {- ^ unique, in-bound ordinals, in order seen -} ordinalNub l xs = foldr (ordinalNubHelper l) (const []) xs IntSet.empty ordinalNubHelper :: Int -> Int -> (IntSet -> [Int]) -> (IntSet -> [Int]) ordinalNubHelper l x next seen | outOfBounds || notUnique = next seen | otherwise = x : next (IntSet.insert x seen) where outOfBounds = x < 0 || l <= x notUnique = x `IntSet.member` seen -- | \(\mathcal{O}(\min(m,n))\). The 'stripSuffix' function drops the given -- suffix from a list. It returns 'Nothing' if the list did not end with the -- suffix given, or 'Just' the list after the suffix, if it does. -- -- >>> stripSuffix "bar" "foobar" -- Just "foo" -- -- >>> stripSuffix "foo" "foo" -- Just "" -- -- >>> stripSuffix "bar" "barfoo" -- Nothing -- -- >>> stripSuffix "foo" "barfoobaz" -- Nothing 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 #-} lens-5.2.3/src/Control/Lens/Internal/Magma.hs0000644000000000000000000002377107346545000017127 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma -- Copyright : (C) 2012-2016 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 Prelude () import Control.Comonad import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Data.Functor.Apply import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Kind import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- 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 -- note the 3rd argument infers as phantom, but that would be unsound type role Magma representational nominal nominal nominal 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 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 #-} 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 :: 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. -- -- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant', -- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma' data TakingWhile p (g :: Type -> Type) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) type role TakingWhile nominal nominal nominal nominal nominal -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. runTakingWhile :: 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 :: 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) = cosieve pafb wa {-# INLINE bazaar #-} -- This constraint is unused intentionally, it protects TakingWhile 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-5.2.3/src/Control/Lens/Internal/Prelude.hs0000644000000000000000000000652207346545000017500 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} #include "lens-common.h" -- | Module which does most common imports (and related CPP) -- needed across the lens library. -- -- This module is intended to stay in other-modules of lens, -- perfectly we'd just use @base-compat-batteries@ -- and not reinvent the wheel. -- That's a reason why this module is different from -- other .Internal modules, which are exposed-modules. -- -- Also this is a "fat" Prelude, re-exporting commonly used, -- non conflicting symbols. -- module Control.Lens.Internal.Prelude ( module Prelude , Semigroup (..) , Monoid (..) , Foldable, foldMap, foldr, foldl, foldl', elem, null, length, traverse_ , Traversable (..) , Applicative (..) , (&), (<&>), (<$>), (<$) -- * Data types , ZipList (..) , NonEmpty (..) -- * Functors , Identity (..) , Compose (..) , Const (..) -- * Control.Applicative , Alternative (..), WrappedMonad (..) #if !MIN_VERSION_base(4,10,0) , liftA2 #endif -- * Data.Coerce , Coercible, coerce -- * Data.Contravariant , Contravariant (..), phantom -- * Data.Monoid , Endo (..), Dual (..) -- * Data.Profunctor , Profunctor (..) , Choice (..), Cochoice (..) , Strong (..), Costrong (..) , Corepresentable (..) , Sieve (..), Cosieve (..) -- * Data.Proxy , Proxy (..) -- * Data.Tagged , Tagged (..) -- * Data.Void , Void, absurd -- * Data.Word , Word ) where import Prelude hiding ( userError -- hiding something always helps with CPP , Applicative (..) , Foldable (..) , Traversable (..) , Monoid (..) , (<$>), (<$) #if MIN_VERSION_base(4,13,0) , Semigroup (..) #endif , Word ) -- Prelude import Control.Applicative (Applicative (..), (<$>), (<$)) -- N.B. liftA2 import Data.Foldable (Foldable, foldMap, elem, foldr, foldl, foldl', traverse_) -- N.B. we don't define Foldable instances, so this way is makes less CPP import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import Data.Traversable (Traversable (..)) import Data.Word (Word) -- Extras import Data.Function ((&)) import Data.Foldable (length, null) #if !MIN_VERSION_base(4,10,0) import Control.Applicative (liftA2) #endif #if MIN_VERSION_base(4,11,0) import Data.Functor ((<&>)) #endif import Control.Applicative (Alternative (..), Const (..), WrappedMonad (..), ZipList (..)) import Data.Coerce (Coercible, coerce) import Data.Functor.Compose (Compose (..)) import Data.Functor.Contravariant (Contravariant (..), phantom) import Data.Functor.Identity (Identity (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid (Endo (..), Dual (..)) import Data.Profunctor (Strong (..), Choice (..), Cochoice (..), Costrong (..)) import Data.Profunctor.Rep (Corepresentable (..)) -- N.B. no Representable import Data.Profunctor.Sieve (Sieve (..), Cosieve (..)) import Data.Profunctor.Unsafe (Profunctor (..)) import Data.Proxy (Proxy (..)) import Data.Tagged (Tagged (..)) import Data.Void (Void, absurd) -- TraversableWithIndex instances for tagged, vector and unordered-containers -- We import this here, so the instances propagate through all (most) of @lens@. import Data.Functor.WithIndex.Instances () #if !(MIN_VERSION_base(4,11,0)) -- | Infix flipped 'fmap'. -- -- @ -- ('<&>') = 'flip' 'fmap' -- @ (<&>) :: Functor f => f a -> (a -> b) -> f b as <&> f = f <$> as {-# INLINE (<&>) #-} infixl 1 <&> #endif lens-5.2.3/src/Control/Lens/Internal/Prism.hs0000644000000000000000000000373407346545000017174 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Prism -- Copyright : (C) 2012-2016 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 Prelude () import Control.Lens.Internal.Prelude ------------------------------------------------------------------------------ -- 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 #-} (#.) _ = coerce {-# INLINE (#.) #-} (.#) p _ = coerce p {-# INLINE (.#) #-} 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-5.2.3/src/Control/Lens/Internal/PrismTH.hs0000644000000000000000000004117607346545000017432 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.PrismTH -- Copyright : (C) 2014-2016 Edward Kmett and Eric Mertens -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.Internal.PrismTH ( makePrisms , makeClassyPrisms , makeDecPrisms ) where import Control.Applicative import Control.Lens.Getter import Control.Lens.Internal.TH import Control.Lens.Lens import Control.Lens.Setter import Control.Monad import Data.Char (isUpper) import qualified Data.List as List import Data.Set.Lens import Data.Traversable import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Lens import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) import Prelude -- | Generate a 'Prism' for each constructor of a data type. -- Isos generated when possible. -- Reviews are created for constructors with existentially -- quantified constructors and GADTs. -- -- /e.g./ -- -- @ -- data FooBarBaz a -- = Foo Int -- | Bar a -- | Baz Int Char -- makePrisms ''FooBarBaz -- @ -- -- will create -- -- @ -- _Foo :: Prism' (FooBarBaz a) Int -- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b -- _Baz :: Prism' (FooBarBaz a) (Int, Char) -- @ makePrisms :: Name {- ^ Type constructor name -} -> DecsQ makePrisms = makePrisms' True -- | Generate a 'Prism' for each constructor of a data type -- and combine them into a single class. No Isos are created. -- Reviews are created for constructors with existentially -- quantified constructors and GADTs. -- -- /e.g./ -- -- @ -- data FooBarBaz a -- = Foo Int -- | Bar a -- | Baz Int Char -- makeClassyPrisms ''FooBarBaz -- @ -- -- will create -- -- @ -- class AsFooBarBaz s a | s -> a where -- _FooBarBaz :: Prism' s (FooBarBaz a) -- _Foo :: Prism' s Int -- _Bar :: Prism' s a -- _Baz :: Prism' s (Int,Char) -- -- _Foo = _FooBarBaz . _Foo -- _Bar = _FooBarBaz . _Bar -- _Baz = _FooBarBaz . _Baz -- -- instance AsFooBarBaz (FooBarBaz a) a -- @ -- -- Generate an "As" class of prisms. Names are selected by prefixing the constructor -- name with an underscore. Constructors with multiple fields will -- construct Prisms to tuples of those fields. -- -- In the event that the name of a data type is also the name of one of its -- constructors, the name of the 'Prism' generated for the data type will be -- prefixed with an extra @_@ (if the data type name is prefix) or @.@ (if the -- name is infix) to disambiguate it from the 'Prism' for the corresponding -- constructor. For example, this code: -- -- @ -- data Quux = Quux Int | Fred Bool -- makeClassyPrisms ''Quux -- @ -- -- will create: -- -- @ -- class AsQuux s where -- __Quux :: Prism' s Quux -- Data type prism -- _Quux :: Prism' s Int -- Constructor prism -- _Fred :: Prism' s Bool -- -- _Quux = __Quux . _Quux -- _Fred = __Quux . _Fred -- -- instance AsQuux Quux -- @ makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ makeClassyPrisms = makePrisms' False -- | Main entry point into Prism generation for a given type constructor name. makePrisms' :: Bool -> Name -> DecsQ makePrisms' normal typeName = do info <- D.reifyDatatype typeName let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given 'Dec' makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ makeDecPrisms normal dec = do info <- D.normalizeDec dec let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given type, normalized constructors, and -- an optional name to be used for generating a prism class. -- This function dispatches between Iso generation, normal top-level -- prisms, and classy prisms. makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ -- special case: single constructor, not classy -> make iso makeConsPrisms t [con@(NCon _ [] [] _)] Nothing = makeConIso t con -- top-level definitions makeConsPrisms t cons Nothing = fmap concat $ for cons $ \con -> do let conName = view nconName con stab <- computeOpticType t cons con let n = prismName conName sequenceA ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab))) , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] ] ++ inlinePragma n ) -- classy prism class and instance makeConsPrisms t cons (Just typeName) = sequenceA [ makeClassyPrismClass t className methodName cons , makeClassyPrismInstance t className methodName cons ] where typeNameBase = nameBase typeName className = mkName ("As" ++ typeNameBase) sameNameAsCon = any (\con -> nameBase (view nconName con) == typeNameBase) cons methodName = prismName' sameNameAsCon typeName data OpticType = PrismType | ReviewType data Stab = Stab Cxt OpticType Type Type Type Type simplifyStab :: Stab -> Stab simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b -- simplification uses t and b because those types -- are interesting in the Review case stabSimple :: Stab -> Bool stabSimple (Stab _ _ s t a b) = s == t && a == b stabToType :: Set Name -> Stab -> Type stabToType clsTVBNames stab@(Stab cx ty s t a b) = quantifyType' clsTVBNames cx stabTy where stabTy = case ty of PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b] | otherwise -> prismTypeName `conAppsT` [s,t,a,b] ReviewType -> reviewTypeName `conAppsT` [t,b] stabType :: Stab -> OpticType stabType (Stab _ o _ _ _ _) = o computeOpticType :: Type -> [NCon] -> NCon -> Q Stab computeOpticType t cons con = do let cons' = List.delete con cons if null (_nconVars con) then computePrismType t (view nconCxt con) cons' con else computeReviewType t (view nconCxt con) (view nconTypes con) computeReviewType :: Type -> Cxt -> [Type] -> Q Stab computeReviewType s' cx tys = do let t = s' s <- fmap VarT (newName "s") a <- fmap VarT (newName "a") b <- toTupleT (map return tys) return (Stab cx ReviewType s t a b) -- | Compute the full type-changing Prism type given an outer type, -- list of constructors, and target constructor name. Additionally -- return 'True' if the resulting type is a "simple" prism. computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab computePrismType t cx cons con = do let ts = view nconTypes con unbound = setOf typeVars t Set.\\ setOf typeVars cons sub <- sequenceA (Map.fromSet (newName . nameBase) unbound) b <- toTupleT (map return ts) a <- toTupleT (map return (substTypeVars sub ts)) let s = substTypeVars sub t return (Stab cx PrismType s t a b) computeIsoType :: Type -> [Type] -> TypeQ computeIsoType t' fields = do sub <- sequenceA (Map.fromSet (newName . nameBase) (setOf typeVars t')) let t = return t' s = return (substTypeVars sub t') b = toTupleT (map return fields) a = toTupleT (map return (substTypeVars sub fields)) ty | Map.null sub = appsT (conT iso'TypeName) [t,b] | otherwise = appsT (conT isoTypeName) [s,t,a,b] quantifyType [] <$> ty -- | Construct either a Review or Prism as appropriate makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ makeConOpticExp stab cons con = case stabType stab of PrismType -> makeConPrismExp stab cons con ReviewType -> makeConReviewExp con -- | Construct an iso declaration makeConIso :: Type -> NCon -> DecsQ makeConIso s con = do let ty = computeIsoType s (view nconTypes con) defName = prismName (view nconName con) sequenceA ( [ sigD defName ty , valD (varP defName) (normalB (makeConIsoExp con)) [] ] ++ inlinePragma defName ) -- | Construct prism expression -- -- prism <> <> makeConPrismExp :: Stab -> [NCon] {- ^ constructors -} -> NCon {- ^ target constructor -} -> ExpQ makeConPrismExp stab cons con = appsE [varE prismValName, reviewer, remitter] where ts = view nconTypes con fields = length ts conName = view nconName con reviewer = makeReviewer conName fields remitter | stabSimple stab = makeSimpleRemitter conName (length cons) fields | otherwise = makeFullRemitter cons conName -- | Construct an Iso expression -- -- iso <> <> makeConIsoExp :: NCon -> ExpQ makeConIsoExp con = appsE [varE isoValName, remitter, reviewer] where conName = view nconName con fields = length (view nconTypes con) reviewer = makeReviewer conName fields remitter = makeIsoRemitter conName fields -- | Construct a Review expression -- -- unto (\(x,y,z) -> Con x y z) makeConReviewExp :: NCon -> ExpQ makeConReviewExp con = appE (varE untoValName) reviewer where conName = view nconName con fields = length (view nconTypes con) reviewer = makeReviewer conName fields ------------------------------------------------------------------------ -- Prism and Iso component builders ------------------------------------------------------------------------ -- | Construct the review portion of a prism. -- -- (\(x,y,z) -> Con x y z) :: b -> t makeReviewer :: Name -> Int -> ExpQ makeReviewer conName fields = do xs <- newNames "x" fields lam1E (toTupleP (map varP xs)) (conE conName `appsE1` map varE xs) -- | Construct the remit portion of a prism. -- Pattern match only target constructor, no type changing -- -- (\x -> case s of -- Con x y z -> Right (x,y,z) -- _ -> Left x -- ) :: s -> Either s a makeSimpleRemitter :: Name {- The name of the constructor on which this prism focuses -} -> Int {- The number of constructors the parent data type has -} -> Int {- The number of fields the constructor has -} -> ExpQ makeSimpleRemitter conName numCons fields = do x <- newName "x" xs <- newNames "y" fields let matches = [ match (conP conName (map varP xs)) (normalB (appE (conE rightDataName) (toTupleE (map varE xs)))) [] ] ++ [ match wildP (normalB (appE (conE leftDataName) (varE x))) [] | numCons > 1 -- Only generate a catch-all case if there is at least -- one constructor besides the one being focused on. ] lam1E (varP x) (caseE (varE x) matches) -- | Pattern match all constructors to enable type-changing -- -- (\x -> case s of -- Con x y z -> Right (x,y,z) -- Other_n w -> Left (Other_n w) -- ) :: s -> Either t a makeFullRemitter :: [NCon] -> Name -> ExpQ makeFullRemitter cons target = do x <- newName "x" lam1E (varP x) (caseE (varE x) (map mkMatch cons)) where mkMatch (NCon conName _ _ n) = do xs <- newNames "y" (length n) match (conP conName (map varP xs)) (normalB (if conName == target then appE (conE rightDataName) (toTupleE (map varE xs)) else appE (conE leftDataName) (conE conName `appsE1` map varE xs))) [] -- | Construct the remitter suitable for use in an 'Iso' -- -- (\(Con x y z) -> (x,y,z)) :: s -> a makeIsoRemitter :: Name -> Int -> ExpQ makeIsoRemitter conName fields = do xs <- newNames "x" fields lam1E (conP conName (map varP xs)) (toTupleE (map varE xs)) ------------------------------------------------------------------------ -- Classy prisms ------------------------------------------------------------------------ -- | Construct the classy prisms class for a given type and constructors. -- -- class ClassName r <> | r -> <> where -- topMethodName :: Prism' r Type -- conMethodName_n :: Prism' r conTypes_n -- conMethodName_n = topMethodName . conMethodName_n makeClassyPrismClass :: Type {- Outer type -} -> Name {- Class name -} -> Name {- Top method name -} -> [NCon] {- Constructors -} -> DecQ makeClassyPrismClass t className methodName cons = do r <- newName "r" let methodType = appsT (conT prism'TypeName) [varT r,return t] methodss <- traverse (mkMethod r) cons' classD (cxt[]) className (D.plainTV r : vs) (fds r) ( sigD methodName methodType : map return (concat methodss) ) where mkMethod r con = do Stab cx o _ _ _ b <- computeOpticType t cons con let rTy = VarT r stab' = Stab cx o rTy rTy b b defName = view nconName con body = appsE [varE composeValName, varE methodName, varE defName] sequenceA [ sigD defName (return (stabToType (Set.fromList (r:vNames)) stab')) , valD (varP defName) (normalB body) [] ] cons' = map (over nconName prismName) cons vs = D.changeTVFlags bndrReq $ D.freeVariablesWellScoped [t] vNames = map D.tvName vs fds r | null vs = [] | otherwise = [FunDep [r] vNames] -- | Construct the classy prisms instance for a given type and constructors. -- -- instance Classname OuterType where -- topMethodName = id -- conMethodName_n = <> makeClassyPrismInstance :: Type -> Name {- Class name -} -> Name {- Top method name -} -> [NCon] {- Constructors -} -> DecQ makeClassyPrismInstance s className methodName cons = do let vs = D.freeVariablesWellScoped [s] cls = className `conAppsT` (s : map tvbToType vs) instanceD (cxt[]) (return cls) ( valD (varP methodName) (normalB (varE idValName)) [] : [ do stab <- computeOpticType s cons con let stab' = simplifyStab stab valD (varP (prismName conName)) (normalB (makeConOpticExp stab' cons con)) [] | con <- cons , let conName = view nconName con ] ) ------------------------------------------------------------------------ -- Utilities ------------------------------------------------------------------------ -- | Normalized constructor data NCon = NCon { _nconName :: Name , _nconVars :: [Name] , _nconCxt :: Cxt , _nconTypes :: [Type] } deriving (Eq) instance HasTypeVars NCon where typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z where s' = List.foldl' (flip Set.insert) s vars nconName :: Lens' NCon Name nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x)) nconCxt :: Lens' NCon Cxt nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x)) nconTypes :: Lens' NCon [Type] nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x)) -- | Normalize a single 'Con' to its constructor name and field types. normalizeCon :: D.ConstructorInfo -> NCon normalizeCon info = NCon (D.constructorName info) (D.tvName <$> D.constructorVars info) (D.constructorContext info) (D.constructorFields info) -- | Compute a prism's name by prefixing an underscore for normal -- constructors and period for operators. prismName :: Name -> Name prismName = prismName' False -- | Compute a prism's name with a special case for when the type -- constructor matches one of the value constructors. -- -- The overlapping flag will be 'True' in the event that: -- -- 1. We are generating the name of a classy prism for a -- data type, and -- 2. The data type shares a name with one of its -- constructors (e.g., @data A = A@). -- -- In such a scenario, we take care not to generate the same -- prism name that the constructor receives (e.g., @_A@). -- For prefix names, we accomplish this by adding an extra -- underscore; for infix names, an extra dot. prismName' :: Bool {- ^ overlapping constructor -} -> Name {- ^ type constructor -} -> Name {- ^ prism name -} prismName' sameNameAsCon n = case nameBase n of [] -> error "prismName: empty name base?" nb@(x:_) | isUpper x -> mkName (prefix '_' nb) | otherwise -> mkName (prefix '.' nb) -- operator where prefix :: Char -> String -> String prefix char str | sameNameAsCon = char:char:str | otherwise = char:str lens-5.2.3/src/Control/Lens/Internal/Profunctor.hs0000644000000000000000000000104407346545000020233 0ustar0000000000000000module Control.Lens.Internal.Profunctor ( WrappedPafb (..) ) where import Prelude () import Control.Lens.Internal.Prelude newtype WrappedPafb f p a b = WrapPafb { unwrapPafb :: p a (f b) } instance (Functor f, Profunctor p) => Profunctor (WrappedPafb f p) where dimap f g (WrapPafb p) = WrapPafb $ dimap f (fmap g) p instance (Applicative f, Choice p) => Choice (WrappedPafb f p) where left' (WrapPafb p) = WrapPafb $ rmap sequenceL $ left' p where sequenceL (Left a) = fmap Left a sequenceL (Right a) = pure $ Right a lens-5.2.3/src/Control/Lens/Internal/Review.hs0000644000000000000000000000266707346545000017347 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Review -- Copyright : (C) 2012-2016 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 ) where import Data.Bifunctor import Data.Profunctor import Data.Void -- | 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 lens-5.2.3/src/Control/Lens/Internal/Setter.hs0000644000000000000000000000350507346545000017344 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Setter -- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Setter ( -- ** Setters Settable(..) ) where import Prelude () import Control.Applicative.Backwards import Control.Lens.Internal.Prelude import Data.Distributive ----------------------------------------------------------------------------- -- 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 #-} lens-5.2.3/src/Control/Lens/Internal/TH.hs0000644000000000000000000002011107346545000016401 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskellQuotes #-} #ifdef TRUSTWORTHY # if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-} # else {-# LANGUAGE Trustworthy #-} # endif #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.TH -- Copyright : (C) 2013-2016 Edward Kmett and Eric Mertens -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.TH ( module Control.Lens.Internal.TH #if MIN_VERSION_template_haskell(2,21,0) || MIN_VERSION_th_abstraction(0,6,0) , D.TyVarBndrVis , D.bndrReq #endif ) where import Control.Lens.Iso import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Type import Control.Lens.Wrapped import Data.Functor.Contravariant import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D import qualified Language.Haskell.TH.Datatype.TyVarBndr as D -- | Apply arguments to a type constructor appsT :: TypeQ -> [TypeQ] -> TypeQ appsT = foldl appT -- | Apply arguments to a function appsE1 :: ExpQ -> [ExpQ] -> ExpQ appsE1 = foldl appE -- | Construct a tuple type given a list of types. toTupleT :: [TypeQ] -> TypeQ toTupleT [x] = x toTupleT xs = appsT (tupleT (length xs)) xs -- | Construct a tuple value given a list of expressions. toTupleE :: [ExpQ] -> ExpQ toTupleE [x] = x toTupleE xs = tupE xs -- | Construct a tuple pattern given a list of patterns. toTupleP :: [PatQ] -> PatQ toTupleP [x] = x toTupleP xs = tupP xs -- | Apply arguments to a type constructor. conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) -- | Generate many new names from a given base name. newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] newNames base n = sequence [ newName (base++show i) | i <- [1..n] ] -- | Decompose an applied type into its individual components. For example, this: -- -- @ -- Either Int Char -- @ -- -- would be unfolded to this: -- -- @ -- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char]) -- @ -- -- This function ignores explicit parentheses and visible kind applications. unfoldType :: Type -> (Type, [Type]) unfoldType = go [] where go :: [Type] -> Type -> (Type, [Type]) go acc (ForallT _ _ ty) = go acc ty go acc (AppT ty1 ty2) = go (ty2:acc) ty1 go acc (SigT ty _) = go acc ty go acc (ParensT ty) = go acc ty #if MIN_VERSION_template_haskell(2,15,0) go acc (AppKindT ty _) = go acc ty #endif go acc ty = (ty, acc) -- Construct a 'Type' using the datatype's type constructor and type -- parameters. Unlike 'D.datatypeType', kind signatures are preserved to -- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more -- details on this.) datatypeTypeKinded :: D.DatatypeInfo -> Type datatypeTypeKinded di = foldl AppT (ConT (D.datatypeName di)) $ dropSigsIfNonDataFam di $ D.datatypeInstTypes di -- | In an effort to prevent users from having to enable KindSignatures every -- time that they use lens' TH functionality, we strip off reified kind -- annotations from when: -- -- 1. The kind of a type does not contain any kind variables. If it *does* -- contain kind variables, we want to preserve them so that we can generate -- type signatures that preserve the dependency order of kind and type -- variables. (The data types in test/T917.hs contain examples where this -- is important.) This will require enabling `PolyKinds`, but since -- `PolyKinds` implies `KindSignatures`, we can at least accomplish two -- things at once. -- 2. The data type is not an instance of a data family. We make an exception -- for data family instances, since the presence or absence of a kind -- annotation can be the difference between typechecking or not. -- (See T917DataFam in tests/T917.hs for an example.) Moreover, the -- `TypeFamilies` extension implies `KindSignatures`. dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type] dropSigsIfNonDataFam di | isDataFamily (D.datatypeVariant di) = id | otherwise = map dropSig where dropSig :: Type -> Type dropSig (SigT t k) | null (D.freeVariables k) = t dropSig t = t -- | Template Haskell wants type variables declared in a forall, so -- we find all free type variables in a given type and declare them. quantifyType :: Cxt -> Type -> Type quantifyType = quantifyType' Set.empty -- | This function works like 'quantifyType' except that it takes -- a list of variables to exclude from quantification. quantifyType' :: Set Name -> Cxt -> Type -> Type quantifyType' exclude c t = ForallT vs c t where vs = filter (\tvb -> D.tvName tvb `Set.notMember` exclude) $ D.changeTVFlags D.SpecifiedSpec $ D.freeVariablesWellScoped (t:c) -- stable order -- | Convert a 'TyVarBndr' into its corresponding 'Type'. tvbToType :: D.TyVarBndr_ flag -> Type tvbToType = D.elimTV VarT (SigT . VarT) -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t unSigT t = t isDataFamily :: D.DatatypeVariant -> Bool isDataFamily D.Datatype = False isDataFamily D.Newtype = False isDataFamily D.DataInstance = True isDataFamily D.NewtypeInstance = True #if MIN_VERSION_th_abstraction(0,5,0) isDataFamily D.TypeData = False #endif #if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0)) type TyVarBndrVis = D.TyVarBndr_ () bndrReq :: () bndrReq = () #endif ------------------------------------------------------------------------ -- TH-quoted names ------------------------------------------------------------------------ -- Note that this module only TemplateHaskellQuotes, not TemplateHaskell, -- which makes lens able to be used in stage1 cross-compilers. traversalTypeName :: Name traversalTypeName = ''Traversal traversal'TypeName :: Name traversal'TypeName = ''Traversal' lensTypeName :: Name lensTypeName = ''Lens lens'TypeName :: Name lens'TypeName = ''Lens' isoTypeName :: Name isoTypeName = ''Iso iso'TypeName :: Name iso'TypeName = ''Iso' getterTypeName :: Name getterTypeName = ''Getter foldTypeName :: Name foldTypeName = ''Fold prismTypeName :: Name prismTypeName = ''Prism prism'TypeName :: Name prism'TypeName = ''Prism' reviewTypeName :: Name reviewTypeName = ''Review wrappedTypeName :: Name wrappedTypeName = ''Wrapped unwrappedTypeName :: Name unwrappedTypeName = ''Unwrapped rewrappedTypeName :: Name rewrappedTypeName = ''Rewrapped _wrapped'ValName :: Name _wrapped'ValName = '_Wrapped' isoValName :: Name isoValName = 'iso prismValName :: Name prismValName = 'prism untoValName :: Name untoValName = 'unto phantomValName :: Name phantomValName = 'phantom2 phantom2 :: (Functor f, Contravariant f) => f a -> f b phantom2 = phantom {-# INLINE phantom2 #-} composeValName :: Name composeValName = '(.) idValName :: Name idValName = 'id fmapValName :: Name fmapValName = 'fmap pureValName :: Name pureValName = 'pure apValName :: Name apValName = '(<*>) rightDataName :: Name rightDataName = 'Right leftDataName :: Name leftDataName = 'Left ------------------------------------------------------------------------ -- Support for generating inline pragmas ------------------------------------------------------------------------ inlinePragma :: Name -> [DecQ] inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases] lens-5.2.3/src/Control/Lens/Internal/Zoom.hs0000644000000000000000000003036607346545000017027 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Zoom -- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Zoom ( -- * Zoom Focusing(..) , FocusingWith(..) , FocusingPlus(..) , FocusingOn(..) , FocusingMay(..), May(..) , FocusingErr(..), Err(..) , FocusingFree(..), Freed(..) -- * Magnify , Effect(..) , EffectRWS(..) ) where import Prelude () import Control.Lens.Internal.Prelude import Control.Monad import Control.Monad.Trans.Free import Data.Functor.Bind ------------------------------------------------------------------------------ -- Focusing ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.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.Zoom.Zoom' to 'Control.Lens.Zoom.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.Zoom.Zoom' to 'Control.Lens.Zoom.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.Zoom.Zoom' to 'Control.Lens.Zoom.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 #-} #if !(MIN_VERSION_base(4,11,0)) May Nothing `mappend` _ = May Nothing _ `mappend` May Nothing = May Nothing May (Just a) `mappend` May (Just b) = May (Just (mappend a b)) {-# INLINE mappend #-} #endif ------------------------------------------------------------------------------ -- FocusingMay ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.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 #-} #if !(MIN_VERSION_base(4,11,0)) 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 #-} #endif ------------------------------------------------------------------------------ -- FocusingErr ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.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 (<*>) #-} ------------------------------------------------------------------------------ -- Freed ------------------------------------------------------------------------------ -- | Make a 'Monoid' out of 'FreeF' for result collection. newtype Freed f m a = Freed { getFreed :: FreeF f a (FreeT f m a) } instance (Applicative f, Semigroup a, Monad m) => Semigroup (Freed f m a) where Freed (Pure a) <> Freed (Pure b) = Freed $ Pure $ a <> b Freed (Pure a) <> Freed (Free g) = Freed $ Free $ liftA2 (liftM2 (<>)) (pure $ return a) g Freed (Free f) <> Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 (<>)) f (pure $ return b) Freed (Free f) <> Freed (Free g) = Freed $ Free $ liftA2 (liftM2 (<>)) f g instance (Applicative f, Monoid a, Monad m) => Monoid (Freed f m a) where mempty = Freed $ Pure mempty #if !(MIN_VERSION_base(4,11,0)) Freed (Pure a) `mappend` Freed (Pure b) = Freed $ Pure $ a `mappend` b Freed (Pure a) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) (pure $ return a) g Freed (Free f) `mappend` Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 mappend) f (pure $ return b) Freed (Free f) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) f g #endif ------------------------------------------------------------------------------ -- FocusingFree ------------------------------------------------------------------------------ -- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into -- 'Control.Monad.Trans.FreeT' newtype FocusingFree f m k s a = FocusingFree { unfocusingFree :: k (Freed f m s) a } instance Functor (k (Freed f m s)) => Functor (FocusingFree f m k s) where fmap f (FocusingFree as) = FocusingFree (fmap f as) {-# INLINE fmap #-} instance Apply (k (Freed f m s)) => Apply (FocusingFree f m k s) where FocusingFree kf <.> FocusingFree ka = FocusingFree (kf <.> ka) {-# INLINE (<.>) #-} instance Applicative (k (Freed f m s)) => Applicative (FocusingFree f m k s) where pure = FocusingFree . pure {-# INLINE pure #-} FocusingFree kf <*> FocusingFree ka = FocusingFree (kf <*> ka) {-# INLINE (<*>) #-} ----------------------------------------------------------------------------- --- Effect ------------------------------------------------------------------------------- -- | Wrap a monadic effect with a phantom type argument. newtype Effect m r a = Effect { getEffect :: m r } -- type role Effect representational nominal phantom 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, Semigroup r) => Semigroup (Effect m r a) where Effect ma <> Effect mb = Effect (liftM2 (<>) ma mb) {-# INLINE (<>) #-} instance (Monad m, Monoid r) => Monoid (Effect m r a) where mempty = Effect (return mempty) {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) {-# INLINE mappend #-} #endif 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 (<*>) #-} ------------------------------------------------------------------------------ -- 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-5.2.3/src/Control/Lens/Iso.hs0000644000000000000000000004422207346545000015055 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE PolyKinds #-} #else {-# LANGUAGE TypeInType #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Iso -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types, TypeFamilies, FunctionalDependencies -- ---------------------------------------------------------------------------- module Control.Lens.Iso ( -- * Isomorphism Lenses Iso, Iso' , AnIso, AnIso' -- * Isomorphism Construction , iso -- * Consuming Isomorphisms , from , cloneIso , withIso -- * Working with isomorphisms , au , auf , xplat , xplatf , under , mapping -- ** Common Isomorphisms , simple , non, non' , anon , enum , curried, uncurried , flipped , swapped , pattern Swapped , strict, lazy , pattern Strict , pattern Lazy , Reversing(..) , reversed , pattern Reversed , involuted , pattern List -- ** Uncommon Isomorphisms , magma , imagma , Magma -- ** Contravariant functors , contramapping -- * Profunctors , Profunctor(dimap,rmap,lmap) , dimapping , lmapping , rmapping -- * Bifunctors , bimapping , firsting , seconding -- * Coercions , coerced ) where import Control.Lens.Equality (simple) import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Control.Lens.Internal.Iso as Iso import Control.Lens.Internal.Magma import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Type import Data.Bifunctor import Data.Bifunctor.Swap (Swap (..)) import Data.Functor.Identity import Data.Strict.Classes (Strict (..)) import Data.Maybe import Data.Profunctor import Data.Profunctor.Unsafe import Data.Coerce import qualified GHC.Exts as Exts import GHC.Exts (TYPE) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import qualified 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 (Identity b) -> Exchange a b s (Identity 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.over' ('iso' f g) h ≡ g '.' h '.' f -- 'Control.Lens.Setter.over' ('Control.Lens.Iso.from' ('iso' f g)) h ≡ f '.' h '.' g -- @ iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) {-# 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 :: forall s t a b rep (r :: TYPE rep). AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r withIso ai k = case ai (Exchange id Identity) of Exchange sa bt -> k sa (runIdentity #. bt) {-# INLINE withIso #-} -- | Convert from 'AnIso' back to any 'Iso'. -- -- 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 -- -- You may want to think of this combinator as having the following, simpler type: -- -- @ -- au :: AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a -- @ -- -- @ -- au = xplat . from -- @ au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a au k = withIso k $ \ sa bt f -> fmap sa (f bt) {-# 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'. -- -- >>> auf (_Wrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10 -- -- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator -- is 'au' with an extra function argument: -- -- @ -- 'auf' :: 'Iso' s t a b -> ((r -> t) -> e -> s) -> (r -> b) -> e -> a -- @ -- -- but the signature is general. -- -- Note: The direction of the 'Iso' required for this function changed in @lens@ 4.18 to match up -- with the behavior of 'au'. For the old behavior use 'xplatf' or for a version that is compatible -- across both old and new versions of @lens@ you can just use 'coerce'! auf :: (Functor f, Functor g) => AnIso s t a b -> (f t -> g s) -> f b -> g a auf k ftgs fb = withIso k $ \sa bt -> sa <$> ftgs (bt <$> fb) {-# INLINE auf #-} -- | @'xplat' = 'au' . 'from'@ but with a nicer signature. xplat :: Optic (Costar ((->) s)) g s t a b -> ((s -> a) -> g b) -> g t xplat f g = xplatf f g id -- | @'xplatf' = 'auf' . 'from'@ but with a nicer signature. -- -- >>> xplatf (_Unwrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10 -- -- @ -- 'xplatf' :: 'Iso' s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t -- @ xplatf :: Optic (Costar f) g s t a b -> (f a -> g b) -> f s -> g t xplatf = coerce {-# INLINE xplat #-} -- | 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, Functor g) => AnIso s t a b -> Iso (f s) (g t) (f a) (g b) mapping k = withIso k $ \ sa bt -> iso (fmap sa) (fmap bt) {-# INLINE mapping #-} -- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@, then @'non' v@ is an isomorphism from -- @'Maybe' a'@ to @a@. -- -- @ -- 'non' ≡ 'non'' '.' 'only' -- @ -- -- Keep in mind this is only a real isomorphism if you treat the domain as being @'Maybe' (a sans v)@. -- -- This is practically quite useful when you want to have a 'Data.Map.Map' where all the entries should have non-zero values. -- -- >>> 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: -- -- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing -- fromList [] -- -- It can also be used in reverse to exclude a given value: -- -- >>> non 0 # rem 10 4 -- Just 2 -- -- >>> non 0 # rem 10 5 -- Nothing non :: Eq a => a -> Iso' (Maybe a) a non a = non' $ only a {-# INLINE non #-} -- | @'non'' p@ generalizes @'non' (p # ())@ to take any unit 'Prism' -- -- This function generates an isomorphism between @'Maybe' (a | 'isn't' p a)@ and @a@. -- -- >>> Map.singleton "hello" Map.empty & at "hello" . non' _Empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- -- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing -- fromList [] non' :: APrism' a () -> Iso' (Maybe a) a non' p = iso (fromMaybe def) go where def = review (clonePrism p) () go b | has (clonePrism p) b = Nothing | otherwise = Just b {-# INLINE non' #-} -- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate. -- -- This function assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@. -- -- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- -- >>> Map.fromList [("hello",Map.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 #-} -- | -- @ -- '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 :: Swap p => Iso (p a b) (p c d) (p b a) (p d c) swapped = iso swap swap {-# INLINE swapped #-} -- | An 'Iso' between the lazy variant of a structure and its strict -- counterpart. -- -- @ -- 'strict' = 'from' 'lazy' -- @ strict :: Strict lazy strict => Iso' lazy strict strict = iso toStrict toLazy {-# INLINE strict #-} pattern Strict :: Strict s t => t -> s pattern Strict a <- (view strict -> a) where Strict a = review strict a pattern Lazy :: Strict t s => t -> s pattern Lazy a <- (view lazy -> a) where Lazy a = review lazy a pattern Swapped :: Swap p => p b a -> p a b pattern Swapped a <- (view swapped -> a) where Swapped a = review swapped a pattern Reversed :: Reversing t => t -> t pattern Reversed a <- (view reversed -> a) where Reversed a = review reversed a -- | An 'Iso' between the strict variant of a structure and its lazy -- counterpart. -- -- @ -- 'lazy' = 'from' 'strict' -- @ -- lazy :: Strict lazy strict => Iso' strict lazy lazy = iso toLazy toStrict {-# INLINE lazy #-} -- | 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 #-} pattern List :: Exts.IsList l => [Exts.Item l] -> l pattern List a <- (Exts.toList -> a) where List a = Exts.fromList a ------------------------------------------------------------------------------ -- 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 :: Over (Indexed i) (Molten i a b) s t a b -> Iso s t' (Magma i t b a) (Magma j t' c c) imagma l = iso (runMolten #. l sell) (iextract .# Molten) {-# INLINE imagma #-} ------------------------------------------------------------------------------ -- 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, Profunctor q) => AnIso s t a b -> AnIso s' t' a' b' -> Iso (p a s') (q b t') (p s a') (q t b') dimapping f g = withIso f $ \ sa bt -> withIso g $ \ s'a' b't' -> iso (dimap sa s'a') (dimap bt b't') {-# 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, Profunctor q) => AnIso s t a b -> Iso (p a x) (q b y) (p s x) (q 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, Profunctor q) => AnIso s t a b -> Iso (p x s) (q y t) (p x a) (q y b) rmapping g = withIso g $ \ sa bt -> iso (rmap sa) (rmap bt) {-# INLINE rmapping #-} ------------------------------------------------------------------------------ -- Bifunctor ------------------------------------------------------------------------------ -- | Lift two 'Iso's into both arguments of a 'Bifunctor'. -- -- @ -- bimapping :: 'Bifunctor' p => 'Iso' s t a b -> 'Iso' s' t' a' b' -> 'Iso' (p s s') (p t t') (p a a') (p b b') -- bimapping :: 'Bifunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p s s') (p a a') -- @ bimapping :: (Bifunctor f, Bifunctor g) => AnIso s t a b -> AnIso s' t' a' b' -> Iso (f s s') (g t t') (f a a') (g b b') bimapping f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' -> iso (bimap sa s'a') (bimap bt b't') {-# INLINE bimapping #-} -- | Lift an 'Iso' into the first argument of a 'Bifunctor'. -- -- @ -- firsting :: 'Bifunctor' p => 'Iso' s t a b -> 'Iso' (p s x) (p t y) (p a x) (p b y) -- firsting :: 'Bifunctor' p => 'Iso'' s a -> 'Iso'' (p s x) (p a x) -- @ firsting :: (Bifunctor f, Bifunctor g) => AnIso s t a b -> Iso (f s x) (g t y) (f a x) (g b y) firsting p = withIso p $ \ sa bt -> iso (first sa) (first bt) {-# INLINE firsting #-} -- | Lift an 'Iso' into the second argument of a 'Bifunctor'. This is -- essentially the same as 'mapping', but it takes a 'Bifunctor p' -- constraint instead of a 'Functor (p a)' one. -- -- @ -- seconding :: 'Bifunctor' p => 'Iso' s t a b -> 'Iso' (p x s) (p y t) (p x a) (p y b) -- seconding :: 'Bifunctor' p => 'Iso'' s a -> 'Iso'' (p x s) (p x a) -- @ seconding :: (Bifunctor f, Bifunctor g) => AnIso s t a b -> Iso (f x s) (g y t) (f x a) (g y b) seconding p = withIso p $ \ sa bt -> iso (second sa) (second bt) {-# INLINE seconding #-} -- | Data types that are representationally equal are isomorphic. -- -- This is only available on GHC 7.8+ -- -- @since 4.13 coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b coerced l = rmap (fmap coerce) l .# coerce {-# INLINE coerced #-} lens-5.2.3/src/Control/Lens/Lens.hs0000644000000000000000000015055207346545000015230 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE PolyKinds #-} #else {-# LANGUAGE TypeInType #-} #endif #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Lens -- Copyright : (C) 2012-16 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 a -- 'Control.Lens.Getter.Getter' can't require an 'Applicative' constraint. -- -- 'Functor', however, is a constraint on 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 -- 'Contravariant'. -- -- 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 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, withLens , (%%~), (%%=) , (%%@~), (%%@=) , (<%@~), (<%@=) , (<<%@~), (<<%@=) -- ** General Purpose Combinators , (&), (<&>), (??) , (&~) -- * Lateral Composition , choosing , chosen , alongside , inside -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (~) , (<<%~), (<<.~), (<~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=) , (<<%=), (<<.=), (<=) , (<<~) -- * Cloning Lenses , cloneLens , cloneIndexPreservingLens , cloneIndexedLens -- * Arrow operators , overA -- * ALens Combinators , storing , (^#) , (#~), (#%~), (#%%~), (<#~), (<#%~) , (#=), (#%=), (#%%=), (<#=), (<#%=) -- * Common Lenses , devoid , united , head1, last1 -- * Context , Context(..) , Context' , locus -- * Lens fusion , fusing ) where import Prelude () import Control.Arrow import Control.Comonad import Control.Lens.Internal.Context import Control.Lens.Internal.Prelude import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.State as State import Data.Functor.Apply import Data.Functor.Reverse import Data.Functor.Yoneda import Data.Semigroup.Traversable import GHC.Exts (TYPE) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Arrow -- >>> import Control.Monad.State -- >>> import Data.Char (chr) -- >>> import Data.List.NonEmpty (NonEmpty ((:|))) -- >>> import Data.Monoid (Sum (..)) -- >>> import Data.Tree (Tree (Node)) -- >>> 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 <<~ infixl 1 ??, &~ ------------------------------------------------------------------------------- -- 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 = Optical (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 -> a -> s) -> 'Lens'' s a -- @ lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} -- | Obtain a getter and a setter from a lens, reversing 'lens'. withLens :: forall s t a b rep (r :: TYPE rep). ALens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r withLens l f = f (^# l) (flip (storing l)) {-# INLINE withLens #-} -- | Build an index-preserving 'Lens' from a 'Control.Lens.Getter.Getter' and a -- 'Control.Lens.Setter.Setter'. iplens :: (s -> a) -> (s -> b -> t) -> IndexPreservingLens s t a b iplens sa sbt pafb = cotabulate $ \ws -> sbt (extract ws) <$> cosieve 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 #-} -- | This can be used to chain lens operations using @op=@ syntax -- rather than @op~@ syntax for simple non-type-changing cases. -- -- >>> (10,20) & _1 .~ 30 & _2 .~ 40 -- (30,40) -- -- >>> (10,20) &~ do _1 .= 30; _2 .= 40 -- (30,40) -- -- This does not support type-changing assignment, /e.g./ -- -- >>> (10,20) & _1 .~ "hello" -- ("hello",20) (&~) :: s -> State s a -> s s &~ l = execState l s {-# INLINE (&~) #-} -- | ('%%~') 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. -- -- >>> [66,97,116,109,97,110] & each %%~ \a -> ("na", chr a) -- ("nananananana","Batman") -- -- 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) -- @ (%%~) :: LensLike f s t a b -> (a -> f b) -> 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 => Over p ((,) r) s s a b -> p a (r, b) -> m r l %%= f = State.state (l f) {-# INLINE (%%=) #-} ------------------------------------------------------------------------------- -- General Purpose Combinators ------------------------------------------------------------------------------- -- | This is convenient to 'flip' argument order of composite functions defined as: -- -- @ -- fab ?? a = fmap ($ a) fab -- @ -- -- For the 'Functor' instance @f = ((->) r)@ you can reason about this function as if the definition was @('??') ≡ 'flip'@: -- -- >>> (h ?? x) a -- h a x -- -- >>> execState ?? [] $ modify (1:) -- [1] -- -- >>> over _2 ?? ("hello","world") $ length -- ("hello",5) -- -- >>> over ?? length ?? ("hello","world") $ _2 -- ("hello",5) (??) :: Functor f => f (a -> b) -> a -> f b fab ?? a = fmap ($ a) fab {-# INLINE (??) #-} ------------------------------------------------------------------------------- -- Common Lenses ------------------------------------------------------------------------------- -- | Lift a 'Lens' so it can run under a function (or other corepresentable profunctor). -- -- @ -- 'inside' :: 'Lens' s t a b -> 'Lens' (e -> s) (e -> t) (e -> a) (e -> b) -- @ -- -- -- >>> (\x -> (x-1,x+1)) ^. inside _1 $ 5 -- 4 -- -- >>> runState (modify (1:) >> modify (2:)) ^. (inside _2) $ [] -- [2,1] inside :: Corepresentable p => ALens s t a b -> Lens (p e s) (p e t) (p e a) (p e b) inside l f es = o <$> f i where i = cotabulate $ \ e -> ipos $ l sell (cosieve es e) o ea = cotabulate $ \ e -> ipeek (cosieve ea e) $ l sell (cosieve es e) {-# INLINE inside #-} {- -- | Lift a 'Lens' so it can run under a function (or any other corepresentable functor). insideF :: F.Representable f => ALens s t a b -> Lens (f s) (f t) (f a) (f b) insideF l f es = o <$> f i where i = F.tabulate $ \e -> ipos $ l sell (F.index es e) o ea = F.tabulate $ \ e -> ipeek (F.index ea e) $ l sell (F.index es e) {-# INLINE inside #-} -} -- | Merge two lenses, getters, setters, folds or traversals. -- -- @ -- '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 -> cosieve (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 or a 'Getter' from two other getters -- by executing them on their respective halves of a product. -- -- >>> (Left a, Right b)^.alongside chosen chosen -- (a,b) -- -- >>> (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' :: 'Getter' s a -> 'Getter' s' a' -> 'Getter' (s,s') (a,a') -- @ alongside :: LensLike (AlongsideLeft f b') s t a b -> LensLike (AlongsideRight f t) s' t' a' b' -> LensLike f (s, s') (t, t') (a, a') (b, b') alongside l1 l2 f (a1, a2) = getAlongsideRight $ l2 ?? a2 $ \b2 -> AlongsideRight $ getAlongsideLeft $ l1 ?? a1 $ \b1 -> AlongsideLeft $ f (b1,b2) {-# INLINE alongside #-} -- | This 'Lens' lets you 'view' the current 'pos' of any indexed -- 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 -> cosieve 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 operation, ('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) -- @ (<%~) :: LensLike ((,) b) s t a b -> (a -> b) -> s -> (b, t) l <%~ f = l $ (\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 => LensLike ((,)a) s t a a -> a -> 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 => LensLike ((,)a) s t a a -> a -> 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 => LensLike ((,)a) s t a a -> a -> 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) -- @ ( LensLike ((,)a) s t a a -> a -> 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) => LensLike ((,)a) s t a a -> e -> 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 operation, ('Control.Lens.Setter.^^~') is more flexible. -- -- @ -- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) -- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @ (<^^~) :: (Fractional a, Integral e) => LensLike ((,)a) s t a a -> e -> 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 operation, ('Control.Lens.Setter.**~') is more flexible. -- -- @ -- ('<**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<**~') :: 'Floating' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ (<**~) :: Floating a => LensLike ((,)a) s t a a -> a -> 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) -- @ (<||~) :: LensLike ((,)Bool) s t Bool Bool -> Bool -> 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) -- @ (<&&~) :: LensLike ((,)Bool) s t Bool Bool -> Bool -> 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 old value, ('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) -- @ (<<%~) :: LensLike ((,)a) s t a b -> (a -> b) -> s -> (a, t) (<<%~) l = l . lmap (\a -> (a, a)) . second' {-# INLINE (<<%~) #-} -- | Replace 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) -- @ (<<.~) :: LensLike ((,)a) s t a b -> b -> s -> (a, t) l <<.~ b = l $ \a -> (a, b) {-# INLINE (<<.~) #-} -- | Replace the target of a 'Lens' with a 'Just' value, but return the old value. -- -- If you do not need the old value ('Control.Lens.Setter.?~') is more flexible. -- -- >>> import qualified Data.Map as Map -- >>> _2.at "hello" < b -> s -> (a, t) -- ('< b -> s -> (a, t) -- ('< b -> s -> (a, t) -- @ (< b -> s -> (a, t) l <>> (a,b) & _1 <<+~ c -- (a,(a + c,b)) -- -- >>> (a,b) & _2 <<+~ c -- (b,(a,b + c)) -- -- @ -- ('<<+~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<+~') :: 'Num' a => 'Iso'' s a -> a -> s -> (a, s) -- @ (<<+~) :: Num a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<+~ b = l $ \a -> (a, a + b) {-# INLINE (<<+~) #-} -- | Decrement the target of a numerically valued 'Lens' and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.-~') is more flexible. -- -- >>> (a,b) & _1 <<-~ c -- (a,(a - c,b)) -- -- >>> (a,b) & _2 <<-~ c -- (b,(a,b - c)) -- -- @ -- ('<<-~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<-~') :: 'Num' a => 'Iso'' s a -> a -> s -> (a, s) -- @ (<<-~) :: Num a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<-~ b = l $ \a -> (a, a - b) {-# INLINE (<<-~) #-} -- | Multiply the target of a numerically valued 'Lens' and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.-~') is more flexible. -- -- >>> (a,b) & _1 <<*~ c -- (a,(a * c,b)) -- -- >>> (a,b) & _2 <<*~ c -- (b,(a,b * c)) -- -- @ -- ('<<*~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<*~') :: 'Num' a => 'Iso'' s a -> a -> s -> (a, s) -- @ (<<*~) :: Num a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<*~ b = l $ \a -> (a, a * b) {-# INLINE (<<*~) #-} -- | Divide the target of a numerically valued 'Lens' and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.//~') is more flexible. -- -- >>> (a,b) & _1 <>> ("Hawaii",10) & _2 < 'Lens'' s a -> a -> s -> (a, s) -- ('< 'Iso'' s a -> a -> s -> (a, s) -- @ (< LensLike' ((,) a) s a -> a -> s -> (a, s) l < (a, a / b) {-# INLINE (< 'Lens'' s a -> e -> s -> (a, s) -- ('<<^~') :: ('Num' a, 'Integral' e) => 'Iso'' s a -> e -> s -> (a, s) -- @ (<<^~) :: (Num a, Integral e) => LensLike' ((,) a) s a -> e -> s -> (a, s) l <<^~ e = l $ \a -> (a, a ^ e) {-# INLINE (<<^~) #-} -- | Raise the target of a fractionally valued 'Lens' to an integral power and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.^^~') is more flexible. -- -- @ -- ('<<^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) -- ('<<^^~') :: ('Fractional' a, 'Integral' e) => 'Iso'' s a -> e -> S -> (a, s) -- @ (<<^^~) :: (Fractional a, Integral e) => LensLike' ((,) a) s a -> e -> s -> (a, s) l <<^^~ e = l $ \a -> (a, a ^^ e) {-# INLINE (<<^^~) #-} -- | Raise the target of a floating-point valued 'Lens' to an arbitrary power and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.**~') is more flexible. -- -- >>> (a,b) & _1 <<**~ c -- (a,(a**c,b)) -- -- >>> (a,b) & _2 <<**~ c -- (b,(a,b**c)) -- -- @ -- ('<<**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<**~') :: 'Floating' a => 'Iso'' s a -> a -> s -> (a, s) -- @ (<<**~) :: Floating a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<**~ e = l $ \a -> (a, a ** e) {-# INLINE (<<**~) #-} -- | Logically '||' the target of a 'Bool'-valued 'Lens' and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.||~') is more flexible. -- -- >>> (False,6) & _1 <<||~ True -- (False,(True,6)) -- -- >>> ("hello",True) & _2 <<||~ False -- (True,("hello",True)) -- -- @ -- ('<<||~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<<||~') :: 'Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @ (<<||~) :: LensLike' ((,) Bool) s Bool -> Bool -> s -> (Bool, s) l <<||~ b = l $ \a -> (a, b || a) {-# INLINE (<<||~) #-} -- | Logically '&&' the target of a 'Bool'-valued 'Lens' and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.&&~') is more flexible. -- -- >>> (False,6) & _1 <<&&~ True -- (False,(False,6)) -- -- >>> ("hello",True) & _2 <<&&~ False -- (True,("hello",False)) -- -- @ -- ('<<&&~') :: 'Lens'' s Bool -> Bool -> s -> (Bool, s) -- ('<<&&~') :: 'Iso'' s Bool -> Bool -> s -> (Bool, s) -- @ (<<&&~) :: LensLike' ((,) Bool) s Bool -> Bool -> s -> (Bool, s) l <<&&~ b = l $ \a -> (a, b && a) {-# INLINE (<<&&~) #-} -- | Modify the target of a monoidally valued 'Lens' by using ('<>') a new value and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.<>~') is more flexible. -- -- >>> (Sum a,b) & _1 <<<>~ Sum c -- (Sum {getSum = a},(Sum {getSum = a + c},b)) -- -- >>> _2 <<<>~ ", 007" $ ("James", "Bond") -- ("Bond",("James","Bond, 007")) -- -- @ -- ('<<<>~') :: 'Semigroup' r => 'Lens'' s r -> r -> s -> (r, s) -- ('<<<>~') :: 'Semigroup' r => 'Iso'' s r -> r -> s -> (r, s) -- @ (<<<>~) :: Semigroup r => LensLike' ((,) r) s r -> r -> s -> (r, s) l <<<>~ b = l $ \a -> (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 -- @ (<%=) :: MonadState s m => LensLike ((,)b) s s a b -> (a -> b) -> m b l <%= f = l %%= (\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', 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' a) => '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) => Over p ((,)a) s s a b -> p a b -> m a l <<%= f = l %%= lmap (\a -> (a,a)) (second' f) {-# INLINE (<<%=) #-} -- | Replace the target of a 'Lens' into your 'Monad''s state with a user supplied -- value and return the /old/ value that was replaced. -- -- When applied to a 'Control.Lens.Traversal.Traversal', 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 -> m a -- ('<<.=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> a -> m a -- ('<<.=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> a -> m a -- @ (<<.=) :: MonadState s m => LensLike ((,)a) s s a b -> b -> m a l <<.= b = l %%= \a -> (a,b) {-# INLINE (<<.=) #-} -- | Replace the target of a 'Lens' into your 'Monad''s state with 'Just' a user supplied -- value and return the /old/ value that was replaced. -- -- When applied to a 'Control.Lens.Traversal.Traversal', 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. -- -- @ -- ('< 'Lens' s t a (Maybe b) -> b -> m a -- ('< 'Control.Lens.Iso.Iso' s t a (Maybe b) -> b -> m a -- ('< 'Control.Lens.Traversal.Traversal' s t a (Maybe b) -> b -> m a -- @ (< LensLike ((,)a) s s a (Maybe b) -> b -> m a l < 'Lens'' s a -> a -> m a -- ('<<+=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m a -- @ (<<+=) :: (MonadState s m, Num a) => LensLike' ((,) a) s a -> a -> m a l <<+= n = l %%= \a -> (a, a + n) {-# INLINE (<<+=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by subtracting a value -- and return the /old/ value that was replaced. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.-=') is more flexible. -- -- @ -- ('<<-=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a -- ('<<-=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m a -- @ (<<-=) :: (MonadState s m, Num a) => LensLike' ((,) a) s a -> a -> m a l <<-= n = l %%= \a -> (a, a - n) {-# INLINE (<<-=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by multipling a value -- and return the /old/ value that was replaced. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.*=') is more flexible. -- -- @ -- ('<<*=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a -- ('<<*=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m a -- @ (<<*=) :: (MonadState s m, Num a) => LensLike' ((,) a) s a -> a -> m a l <<*= n = l %%= \a -> (a, a * n) {-# INLINE (<<*=) #-} -- | Modify the target of a 'Lens' into your 'Monad'\s state by dividing by a value -- and return the /old/ value that was replaced. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.//=') is more flexible. -- -- @ -- ('< 'Lens'' s a -> a -> m a -- ('< 'Iso'' s a -> a -> m a -- @ (< LensLike' ((,) a) s a -> a -> m a l < (a, a / n) {-# INLINE (< 'Lens'' s a -> e -> m a -- ('<<^=') :: ('MonadState' s m, 'Num' a, 'Integral' e) => 'Iso'' s a -> a -> m a -- @ (<<^=) :: (MonadState s m, Num a, Integral e) => LensLike' ((,) a) s a -> e -> m a l <<^= n = l %%= \a -> (a, a ^ n) {-# INLINE (<<^=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by raising it by an integral power -- and return the /old/ value that was replaced. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.^^=') is more flexible. -- -- @ -- ('<<^^=') :: ('MonadState' s m, 'Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> m a -- ('<<^^=') :: ('MonadState' s m, 'Fractional' a, 'Integral' e) => 'Iso'' s a -> e -> m a -- @ (<<^^=) :: (MonadState s m, Fractional a, Integral e) => LensLike' ((,) a) s a -> e -> m a l <<^^= n = l %%= \a -> (a, a ^^ n) {-# INLINE (<<^^=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by raising it by an arbitrary power -- and return the /old/ value that was replaced. -- -- 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) => 'Iso'' s a -> a -> m a -- @ (<<**=) :: (MonadState s m, Floating a) => LensLike' ((,) a) s a -> a -> m a l <<**= n = l %%= \a -> (a, a ** n) {-# INLINE (<<**=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by taking its logical '||' with a value -- and return the /old/ value that was replaced. -- -- 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 => 'Iso'' s 'Bool' -> 'Bool' -> m 'Bool' -- @ (<<||=) :: MonadState s m => LensLike' ((,) Bool) s Bool -> Bool -> m Bool l <<||= b = l %%= \a -> (a, a || b) {-# INLINE (<<||=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by taking its logical '&&' with a value -- and return the /old/ value that was replaced. -- -- 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 => 'Iso'' s 'Bool' -> 'Bool' -> m 'Bool' -- @ (<<&&=) :: MonadState s m => LensLike' ((,) Bool) s Bool -> Bool -> m Bool l <<&&= b = l %%= \a -> (a, a && b) {-# INLINE (<<&&=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by using ('<>') -- and return the /old/ value that was replaced. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.<>=') is more flexible. -- -- @ -- ('<<<>=') :: ('MonadState' s m, 'Semigroup' r) => 'Lens'' s r -> r -> m r -- ('<<<>=') :: ('MonadState' s m, 'Semigroup' r) => 'Iso'' s r -> r -> m r -- @ (<<<>=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r l <<<>= b = l %%= \a -> (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 (<<~) #-} -- | ('<>') a 'Semigroup' 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. (<<>~) :: Semigroup m => LensLike ((,)m) s t m m -> m -> s -> (m, t) l <<>~ m = l <%~ (<> m) {-# INLINE (<<>~) #-} -- | ('<>') a 'Semigroup' 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, Semigroup r) => LensLike' ((,)r) s r -> r -> m r l <<>= r = l <%= (<> r) {-# INLINE (<<>=) #-} ------------------------------------------------------------------------------ -- Arrow operators ------------------------------------------------------------------------------ -- | 'Control.Lens.Setter.over' for Arrows. -- -- Unlike 'Control.Lens.Setter.over', 'overA' can't accept a simple -- 'Control.Lens.Setter.Setter', but requires a full lens, or close -- enough. -- -- >>> overA _1 ((+1) *** (+2)) ((1,2),6) -- ((2,4),6) -- -- @ -- overA :: Arrow ar => Lens s t a b -> ar a b -> ar s t -- @ overA :: Arrow ar => LensLike (Context a b) s t a b -> ar a b -> ar s t overA l p = arr (\s -> let (Context f a) = l sell s in (f, a)) >>> second p >>> arr (uncurry id) ------------------------------------------------------------------------------ -- Indexed ------------------------------------------------------------------------------ -- | 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) -- @ (<%@~) :: Over (Indexed i) ((,) b) s t a b -> (i -> a -> b) -> 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) -- @ (<<%@~) :: Over (Indexed i) ((,) a) s t a b -> (i -> a -> b) -> 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) -- @ (%%@~) :: Over (Indexed 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 => Over (Indexed i) ((,) r) s s a b -> (i -> a -> (r, b)) -> m r l %%@= f = State.state (l %%@~ f) {-# 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 => Over (Indexed i) ((,) b) s s a b -> (i -> a -> b) -> m b l <%@= f = l %%@= \ i a -> let b = f i a in (b, b) {-# INLINE (<%@=) #-} -- | 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 => Over (Indexed i) ((,) a) s s a b -> (i -> a -> b) -> m a l <<%@= f = State.state (l (Indexed $ \ i a -> (a, f i a))) {-# 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 l #%%= f = State.state $ \s -> runPretext (l sell s) f {-# 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 #-} data First1 f a = First1 (f a) a instance (Functor f) => Functor (First1 f) where fmap f (First1 fa a) = First1 (f <$> fa) (f a) {-# INLINE fmap #-} instance (Functor f) => Apply (First1 f) where First1 ff f <.> First1 _ x = First1 (($ x) <$> ff) (f x) {-# INLINE (<.>) #-} getFirst1 :: First1 f a -> f a getFirst1 (First1 fa _) = fa {-# INLINE getFirst1 #-} -- | A 'Lens' focusing on the first element of a 'Traversable1' container. -- -- >>> 2 :| [3, 4] & head1 +~ 10 -- 12 :| [3,4] -- -- >>> Identity True ^. head1 -- True head1 :: (Traversable1 t) => Lens' (t a) a head1 f = getFirst1 . traverse1 (\a -> First1 (f a) a) {-# INLINE head1 #-} -- | A 'Lens' focusing on the last element of a 'Traversable1' container. -- -- >>> 2 :| [3, 4] & last1 +~ 10 -- 2 :| [3,14] -- -- >>> Node 'a' [Node 'b' [], Node 'c' []] ^. last1 -- 'c' last1 :: (Traversable1 t) => Lens' (t a) a last1 f = fmap getReverse . head1 f . Reverse {-# INLINE last1 #-} -- | Fuse a composition of lenses using 'Yoneda' to provide 'fmap' fusion. -- -- In general, given a pair of lenses 'foo' and 'bar' -- -- @ -- fusing (foo.bar) = foo.bar -- @ -- -- however, @foo@ and @bar@ are either going to 'fmap' internally or they are trivial. -- -- 'fusing' exploits the 'Yoneda' lemma to merge these separate uses into a single 'fmap'. -- -- This is particularly effective when the choice of functor 'f' is unknown at compile -- time or when the 'Lens' @foo.bar@ in the above description is recursive or complex -- enough to prevent inlining. -- -- @ -- 'fusing' :: 'Lens' s t a b -> 'Lens' s t a b -- @ fusing :: Functor f => LensLike (Yoneda f) s t a b -> LensLike f s t a b fusing t = \f -> lowerYoneda . t (liftYoneda . f) {-# INLINE fusing #-} lens-5.2.3/src/Control/Lens/Level.hs0000644000000000000000000001263407346545000015374 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Level -- Copyright : (C) 2012-16 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.Indexed import Control.Lens.Internal.Level import Control.Lens.Traversal import Control.Lens.Type import Data.Profunctor.Unsafe -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Char levelIns :: BazaarT (->) f a b t -> [Level () a] levelIns = go 0 . (getConst #. bazaar (rmapConst (deepening ()))) where go k z = k `seq` runDeepening z k $ \ xs b -> xs : if b then (go $! k + 1) z else [] {-# INLINE levelIns #-} levelOuts :: BazaarT (->) f a b t -> [Level j b] -> t levelOuts bz = runFlows $ runBazaarT bz $ \ _ -> Flows $ \t -> case t of One _ a : _ -> a _ -> error "levelOuts: wrong shape" {-# INLINE levelOuts #-} -- | This provides a breadth-first 'Traversal' or 'Fold' of the individual -- 'levels' of any other 'Traversal' or 'Fold' 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')] -- -- @ -- 'levels' :: 'Traversal' s t a b -> 'IndexedTraversal' 'Int' s t ('Level' () a) ('Level' () b) -- 'levels' :: 'Fold' s a -> 'IndexedFold' 'Int' s ('Level' () a) -- @ -- -- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information -- in an order that violates the 'Applicative' laws. levels :: Applicative f => Traversing (->) f s t a b -> IndexedLensLike Int f s t (Level () a) (Level () b) levels l f s = levelOuts bz <$> traversed f (levelIns bz) where bz = l sell s {-# INLINE levels #-} -- This is only a temporary work around added to deal with a bug in an unreleased version -- of GHC 7.10. We should remove it as soon as we're able. rmapConst :: Profunctor p => p a b -> p a (Const b x) rmapConst p = Const #. p {-# INLINE rmapConst #-} ilevelIns :: BazaarT (Indexed i) f a b t -> [Level i a] ilevelIns = go 0 . (getConst #. bazaar (Indexed $ \ i -> rmapConst (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 :: BazaarT (Indexed i) f a b t -> [Level j b] -> t ilevelOuts bz = runFlows $ runBazaarT bz $ Indexed $ \ _ _ -> Flows $ \t -> case t of One _ a : _ -> a _ -> error "ilevelOuts: wrong shape" {-# INLINE ilevelOuts #-} -- | This provides a breadth-first 'Traversal' or 'Fold' of the individual -- levels of any other 'Traversal' or 'Fold' 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')] -- -- @ -- 'ilevels' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' 'Int' s t ('Level' i a) ('Level' i b) -- 'ilevels' :: 'IndexedFold' i s a -> 'IndexedFold' 'Int' s ('Level' i a) -- @ -- -- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information -- in an order that violates the 'Applicative' laws. ilevels :: Applicative f => Traversing (Indexed i) f s t a b -> IndexedLensLike Int f 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-5.2.3/src/Control/Lens/Operators.hs0000644000000000000000000000421507346545000016277 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Operators -- Copyright : (C) 2012-16 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 ( -- output from scripts/operators -h -- * "Control.Lens.Cons" (<|) , (|>) -- * "Control.Lens.Fold" , (^..) , (^?) , (^?!) , (^@..) , (^@?) , (^@?!) -- * "Control.Lens.Getter" , (^.) , (^@.) -- * "Control.Lens.Indexed" , (<.) , (.>) , (<.>) -- * "Control.Lens.Lens" , (%%~) , (%%=) , (&) , (&~) , (<&>) , (??) , (<%~) , (<+~) , (<-~) , (<*~) , (~) , (<%=) , (<+=) , (<-=) , (<*=) , (=) , (<<~) , (<<>~) , (<<>=) , (<%@~) , (<<%@~) , (%%@~) , (%%@=) , (<%@=) , (<<%@=) , (^#) , (#~) , (#%~) , (#%%~) , (#=) , (#%=) , (<#%~) , (<#%=) , (#%%=) , (<#~) , (<#=) -- * "Control.Lens.Plated" , (...) -- * "Control.Lens.Review" , (#) -- * "Control.Lens.Setter" , (%~) , (.~) , (?~) , (<.~) , (~) , (<>=) , (.@~) , (.@=) , (%@~) , (%@=) ) where import Control.Lens lens-5.2.3/src/Control/Lens/Plated.hs0000644000000000000000000007334107346545000015540 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell #endif #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Plated -- Copyright : (C) 2012-16 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 , cosmos, cosmosOf, cosmosOn, cosmosOnOf , transform, transformOf, transformOn, transformOnOf , transformM, transformMOf, transformMOn, transformMOnOf , contexts, contextsOf, contextsOn, contextsOnOf , holes, holesOn, holesOnOf , para, paraOf , (...), deep -- * Compos -- $compos , composOpFold -- * Parts , parts -- * Generics , gplate , gplate1 , GPlated , GPlated1 ) where import Prelude () import Control.Comonad.Cofree import qualified Control.Comonad.Trans.Cofree as CoTrans import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Indexed import Control.Lens.Internal.Context import Control.Lens.Internal.Prelude import Control.Lens.Type import Control.Lens.Setter import Control.Lens.Traversal import Control.Monad.Free as Monad import Control.Monad.Free.Church as Church import Control.Monad.Trans.Free as Trans import qualified Language.Haskell.TH as TH import Data.Data import Data.Data.Lens import Data.Tree import GHC.Generics -- $setup -- >>> :set -XDeriveGeneric -XDeriveDataTypeable -- >>> import Control.Applicative -- >>> import Data.Data (Data) -- >>> import GHC.Generics (Generic) -- >>> import Control.Lens -- | 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') -- @ -- -- @ -- 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') -- @ -- -- @ -- 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 default plate :: Data a => Traversal' a a plate = uniplate instance Plated [a] where plate f (x:xs) = (x:) <$> f xs plate _ [] = pure [] instance Traversable f => Plated (Monad.Free f a) where plate f (Monad.Free as) = Monad.Free <$> traverse f as plate _ x = pure x instance (Traversable f, Traversable m) => Plated (Trans.FreeT f m a) where plate f (Trans.FreeT xs) = Trans.FreeT <$> traverse (traverse f) xs instance Traversable f => Plated (Church.F f a) where plate f = fmap Church.toF . plate (fmap Church.fromF . f . Church.toF) . Church.fromF -- -- This one can't work -- -- instance (Traversable f, Traversable m) => Plated (ChurchT.FT f m a) where -- plate f = fmap ChurchT.toFT . plate (fmap ChurchT.fromFT . f . ChurchT.toFT) . ChurchT.fromFT instance (Traversable f, Traversable w) => Plated (CoTrans.CofreeT f w a) where plate f (CoTrans.CofreeT xs) = CoTrans.CofreeT <$> traverse (traverse f) xs instance Traversable f => Plated (Cofree f a) where plate f (a :< as) = (:<) a <$> traverse f as instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as {- Default uniplate instances -} instance Plated TH.Exp instance Plated TH.Dec instance Plated TH.Con instance Plated TH.Type instance Plated TH.Stmt instance Plated TH.Pat infixr 9 ... -- | Compose through a plate (...) :: (Applicative f, Plated c) => LensLike f s t c c -> Over p f c c a b -> Over p f s t a b l ... m = l . plate . m {-# INLINE (...) #-} -- | Try to apply a traversal to all transitive descendants of a 'Plated' container, but -- do not recurse through matching descendants. -- -- @ -- 'deep' :: 'Plated' s => 'Fold' s a -> 'Fold' s a -- 'deep' :: 'Plated' s => 'IndexedFold' s a -> 'IndexedFold' s a -- 'deep' :: 'Plated' s => 'Traversal' s s a b -> 'Traversal' s s a b -- 'deep' :: 'Plated' s => 'IndexedTraversal' s s a b -> 'IndexedTraversal' s s a b -- @ deep :: (Conjoined p, Applicative f, Plated s) => Traversing p f s s a b -> Over p f s s a b deep = deepOf plate ------------------------------------------------------------------------------- -- 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 '<|>' 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 '<|>' 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 b a b -> (b -> Maybe a) -> a -> b 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' :: 'Control.Lens.Iso.Iso'' s a -> 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Lens'' s a -> 'Lens'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s -- 'rewriteOnOf' :: 'Setter'' s a -> 'Setter'' a a -> (a -> 'Maybe' a) -> s -> s -- @ rewriteOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> 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 b a b -> (b -> m (Maybe a)) -> a -> m b 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 b -> LensLike (WrappedMonad m) a b a b -> (b -> 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 (Endo [a]) a a -> a -> [a] universeOf l = \x -> appEndo (universeOf' l x) [] {-# INLINE universeOf #-} universeOf' :: Getting (Endo [a]) a a -> a -> Endo [a] universeOf' l = go where go a = Endo (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 (Endo [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 (Endo [a]) s a -> Getting (Endo [a]) a a -> s -> [a] universeOnOf b = \p x -> appEndo (foldMapOf b (universeOf' p) x) [] {-# INLINE universeOnOf #-} -- | Fold over all transitive descendants of a 'Plated' container, including itself. cosmos :: Plated a => Fold a a cosmos = cosmosOf plate {-# INLINE cosmos #-} -- | Given a 'Fold' that knows how to locate immediate children, fold all of the transitive descendants of a node, including itself. -- -- @ -- 'cosmosOf' :: 'Fold' a a -> 'Fold' a a -- @ cosmosOf :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a -- The 'Contravariant' constraint isn't required for the implementation. Since any 'Traversal' produced with 'cosmosOf' is more likely than -- not to be broken, the additional constraint serves to restrict 'cosmosOf' to 'Fold's. cosmosOf d f s = f s *> d (cosmosOf d f) s {-# INLINE cosmosOf #-} -- | Given a 'Fold' that knows how to find 'Plated' parts of a container fold them and all of their descendants, recursively. -- -- @ -- 'cosmosOn' :: 'Plated' a => 'Fold' s a -> 'Fold' s a -- @ cosmosOn :: (Applicative f, Contravariant f, Plated a) => LensLike' f s a -> LensLike' f s a cosmosOn d = cosmosOnOf d plate {-# INLINE cosmosOn #-} -- | Given a 'Fold' that knows how to locate immediate children, fold all of the transitive descendants of a node, including itself that lie -- in a region indicated by another 'Fold'. -- -- @ -- 'cosmosOnOf' :: 'Fold' s a -> 'Fold' a a -> 'Fold' s a -- @ cosmosOnOf :: (Applicative f, Contravariant f) => LensLike' f s a -> LensLike' f a a -> LensLike' f s a cosmosOnOf d p = d . cosmosOf p {-# INLINE cosmosOnOf #-} ------------------------------------------------------------------------------- -- 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 b a b -> (b -> b) -> a -> b 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 b -> ASetter a b a b -> (b -> b) -> 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 b a b -> (b -> m b) -> a -> m b 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 b -> LensLike (WrappedMonad m) a b a b -> (b -> m b) -> 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 => Over 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 -> Over 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' '.' 'Control.Lens.Getter.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 #-} ------------------------------------------------------------------------------- -- Generics ------------------------------------------------------------------------------- -- | Implement 'plate' operation for a type using its 'Generic' instance. -- -- Note: the behavior may be different than with 'uniplate' in some special cases. -- 'gplate' doesn't look through other types in a group of mutually -- recursive types. -- -- For example consider mutually recursive even and odd natural numbers: -- -- >>> data Even = Z | E Odd deriving (Show, Generic, Data); data Odd = O Even deriving (Show, Generic, Data) -- -- Then 'uniplate', which is based on `Data`, finds -- all even numbers less or equal than four: -- -- >>> import Data.Data.Lens (uniplate) -- >>> universeOf uniplate (E (O (E (O Z)))) -- [E (O (E (O Z))),E (O Z),Z] -- -- but 'gplate' doesn't see through @Odd@. -- -- >>> universeOf gplate (E (O (E (O Z)))) -- [E (O (E (O Z)))] -- -- If using 'Data' is not an option, you can still write the traversal manually. -- It is sometimes useful to use helper traversals -- -- >>> :{ -- let oddeven :: Traversal' Odd Even -- oddeven f (O n) = O <$> f n -- evenplate :: Traversal' Even Even -- evenplate f Z = pure Z -- evenplate f (E n) = E <$> oddeven f n -- :} -- -- >>> universeOf evenplate (E (O (E (O Z)))) -- [E (O (E (O Z))),E (O Z),Z] -- gplate :: (Generic a, GPlated a (Rep a)) => Traversal' a a gplate f x = GHC.Generics.to <$> gplate' f (GHC.Generics.from x) {-# INLINE gplate #-} class GPlated a g where gplate' :: Traversal' (g p) a instance GPlated a f => GPlated a (M1 i c f) where gplate' f (M1 x) = M1 <$> gplate' f x {-# INLINE gplate' #-} instance (GPlated a f, GPlated a g) => GPlated a (f :+: g) where gplate' f (L1 x) = L1 <$> gplate' f x gplate' f (R1 x) = R1 <$> gplate' f x {-# INLINE gplate' #-} instance (GPlated a f, GPlated a g) => GPlated a (f :*: g) where gplate' f (x :*: y) = (:*:) <$> gplate' f x <*> gplate' f y {-# INLINE gplate' #-} instance {-# OVERLAPPING #-} GPlated a (K1 i a) where gplate' f (K1 x) = K1 <$> f x {-# INLINE gplate' #-} instance GPlated a (K1 i b) where gplate' _ = pure {-# INLINE gplate' #-} instance GPlated a U1 where gplate' _ = pure {-# INLINE gplate' #-} instance GPlated a V1 where gplate' _ v = v `seq` error "GPlated/V1" {-# INLINE gplate' #-} instance GPlated a (URec b) where gplate' _ = pure {-# INLINE gplate' #-} -- | Implement 'plate' operation for a type using its 'Generic1' instance. gplate1 :: (Generic1 f, GPlated1 f (Rep1 f)) => Traversal' (f a) (f a) gplate1 f x = GHC.Generics.to1 <$> gplate1' f (GHC.Generics.from1 x) {-# INLINE gplate1 #-} class GPlated1 f g where gplate1' :: Traversal' (g a) (f a) -- | recursive match instance GPlated1 f g => GPlated1 f (M1 i c g) where gplate1' f (M1 x) = M1 <$> gplate1' f x {-# INLINE gplate1' #-} -- | recursive match instance (GPlated1 f g, GPlated1 f h) => GPlated1 f (g :+: h) where gplate1' f (L1 x) = L1 <$> gplate1' f x gplate1' f (R1 x) = R1 <$> gplate1' f x {-# INLINE gplate1' #-} -- | recursive match instance (GPlated1 f g, GPlated1 f h) => GPlated1 f (g :*: h) where gplate1' f (x :*: y) = (:*:) <$> gplate1' f x <*> gplate1' f y {-# INLINE gplate1' #-} -- | ignored instance GPlated1 f (K1 i a) where gplate1' _ = pure {-# INLINE gplate1' #-} -- | ignored instance GPlated1 f Par1 where gplate1' _ = pure {-# INLINE gplate1' #-} -- | ignored instance GPlated1 f U1 where gplate1' _ = pure {-# INLINE gplate1' #-} -- | ignored instance GPlated1 f V1 where gplate1' _ = pure {-# INLINE gplate1' #-} -- | match instance {-# OVERLAPPING #-} GPlated1 f (Rec1 f) where gplate1' f (Rec1 x) = Rec1 <$> f x {-# INLINE gplate1' #-} -- | ignored instance GPlated1 f (Rec1 g) where gplate1' _ = pure {-# INLINE gplate1' #-} -- | recursive match under outer 'Traversable' instance instance (Traversable t, GPlated1 f g) => GPlated1 f (t :.: g) where gplate1' f (Comp1 x) = Comp1 <$> traverse (gplate1' f) x {-# INLINE gplate1' #-} -- | ignored instance GPlated1 f (URec a) where gplate1' _ = pure {-# INLINE gplate1' #-} lens-5.2.3/src/Control/Lens/Prism.hs0000644000000000000000000003054307346545000015416 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Prism -- Copyright : (C) 2012-16 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 , withPrism , clonePrism , outside , aside , without , below , isn't , matching , matching' -- * Common Prisms , _Left , _Right , _Just , _Nothing , _Void , _Show , only , nearly , Prefixed(..) , Suffixed(..) -- * Prismatic profunctors , Choice(..) ) where import Prelude () import Control.Applicative import qualified Control.Lens.Internal.List as List import Control.Lens.Internal.Prism import Control.Lens.Internal.Prelude import Control.Lens.Lens import Control.Lens.Review import Control.Lens.Type import Control.Monad import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.List as List import Data.Profunctor.Rep import qualified Data.Text as TS import qualified Data.Text.Lazy as TL -- $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 (Identity b) -> Market a b s (Identity t) -- | @ -- type APrism' = 'Simple' 'APrism' -- @ type APrism' s a = APrism s s a a -- | Convert 'APrism' to the pair of functions that characterize it. withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r withPrism k f = case coerce (k (Market Identity Right)) of Market bt seta -> f bt seta {-# INLINE withPrism #-} -- | 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 = withPrism k $ \bt sta -> prism bt sta {-# 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)@ -- TODO: can we make this work with merely Strong? outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r) outside k = withPrism k $ \bt seta f ft -> f (lmap bt ft) <&> \fa -> tabulate $ either (sieve ft) (sieve fa) . seta {-# INLINE outside #-} -- | 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 k' = withPrism k $ \bt seta -> withPrism k' $ \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 #-} -- | 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 = withPrism k $ \bt seta -> prism (fmap bt) $ \(e,s) -> case seta s of Left t -> Left (e,t) Right a -> Right (e,a) {-# INLINE aside #-} -- | 'lift' a 'Prism' through a 'Traversable' functor, giving a Prism that matches only if all the elements of the container match the 'Prism'. -- -- >>> [Left 1, Right "foo", Left 4, Right "woot"]^..below _Right -- [] -- -- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"]^..below _Right -- [["hail hydra!","foo","blah","woot"]] below :: Traversable f => APrism' s a -> Prism' (f s) (f a) below k = withPrism k $ \bt seta -> prism (fmap bt) $ \s -> case traverse seta s of Left _ -> Left s Right t -> Right t {-# INLINE below #-} -- | Check to see if this 'Prism' doesn't match. -- -- >>> isn't _Left (Right 12) -- True -- -- >>> isn't _Left (Left 12) -- False -- -- >>> isn't _Empty [] -- False -- -- @ -- 'isn't' = 'not' . 'Control.Lens.Extra.is' -- 'isn't' = 'hasn't' -- @ isn't :: APrism s t a b -> s -> Bool isn't k s = case matching k s of Left _ -> True Right _ -> False {-# INLINE isn't #-} -- | Retrieve the value targeted by a 'Prism' or return the -- original value while allowing the type to change if it does -- not match. -- -- >>> matching _Just (Just 12) -- Right 12 -- -- >>> matching _Just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int -- Left Nothing matching :: APrism s t a b -> s -> Either t a matching k = withPrism k $ \_ seta -> seta {-# INLINE matching #-} -- | Like 'matching', but also works for combinations of 'Lens' and 'Prism's, -- and also 'Traversal's. -- -- >>> matching' (_2 . _Just) ('x', Just True) -- Right True -- -- >>> matching' (_2 . _Just) ('x', Nothing :: Maybe Int) :: Either (Char, Maybe Bool) Int -- Left ('x',Nothing) -- -- >>> matching' traverse "" :: Either [Int] Char -- Left [] -- -- >>> matching' traverse "xyz" :: Either [Int] Char -- Right 'x' matching' :: LensLike (Either a) s t a b -> s -> Either t a matching' k = either Right Left . k Left {-# INLINE matching' #-} ------------------------------------------------------------------------------ -- 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 #-} -- | This 'Prism' compares for approximate equality with a given value and a predicate for testing, -- an example where the value is the empty list and the predicate checks that a list is empty (same -- as 'Control.Lens.Empty._Empty' with the 'Control.Lens.Empty.AsEmpty' list instance): -- -- >>> nearly [] null # () -- [] -- >>> [1,2,3,4] ^? nearly [] null -- Nothing -- -- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@ -- -- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are somewhat constrained. -- -- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid 'Prism'. -- -- This is useful when working with a type where you can test equality for only a subset of its -- values, and the prism selects such a value. nearly :: a -> (a -> Bool) -> Prism' a () nearly a p = prism' (\() -> a) $ guard . p {-# INLINE nearly #-} -- | This is an improper prism for text formatting based on 'Read' and 'Show'. -- -- This 'Prism' is \"improper\" in the sense that it normalizes the text formatting, but round tripping -- is idempotent given sane 'Read'/'Show' instances. -- -- >>> _Show # 2 -- "2" -- -- >>> "EQ" ^? _Show :: Maybe Ordering -- Just EQ -- -- @ -- '_Show' ≡ 'prism'' 'show' 'readMaybe' -- @ _Show :: (Read a, Show a) => Prism' String a _Show = prism show $ \s -> case reads s of [(a,"")] -> Right a _ -> Left s {-# INLINE _Show #-} class Prefixed t where -- | A 'Prism' stripping a prefix from a sequence 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 :: t -> Prism' t t instance Eq a => Prefixed [a] where prefixed ps = prism' (ps ++) (List.stripPrefix ps) {-# INLINE prefixed #-} instance Prefixed TS.Text where prefixed p = prism' (p <>) (TS.stripPrefix p) {-# INLINE prefixed #-} instance Prefixed TL.Text where prefixed p = prism' (p <>) (TL.stripPrefix p) {-# INLINE prefixed #-} instance Prefixed BS.ByteString where prefixed p = prism' (p <>) (BS.stripPrefix p) {-# INLINE prefixed #-} instance Prefixed BL.ByteString where prefixed p = prism' (p <>) (BL.stripPrefix p) {-# INLINE prefixed #-} class Suffixed t where -- | A 'Prism' stripping a suffix from a sequence when used as a 'Traversal', -- or appending that suffix when run backwards: -- -- >>> "review" ^? suffixed "view" -- Just "re" -- -- >>> "review" ^? suffixed "tire" -- Nothing -- -- >>> suffixed ".o" # "hello" -- "hello.o" suffixed :: t -> Prism' t t instance Eq a => Suffixed [a] where suffixed qs = prism' (++ qs) (List.stripSuffix qs) {-# INLINE suffixed #-} instance Suffixed TS.Text where suffixed qs = prism' (<> qs) (TS.stripSuffix qs) {-# INLINE suffixed #-} instance Suffixed TL.Text where suffixed qs = prism' (<> qs) (TL.stripSuffix qs) {-# INLINE suffixed #-} instance Suffixed BS.ByteString where suffixed qs = prism' (<> qs) (BS.stripSuffix qs) {-# INLINE suffixed #-} instance Suffixed BL.ByteString where suffixed qs = prism' (<> qs) (BL.stripSuffix qs) {-# INLINE suffixed #-} lens-5.2.3/src/Control/Lens/Profunctor.hs0000644000000000000000000001050707346545000016463 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- -- | This module provides conversion functions between the optics defined in -- this library and 'Profunctor'-based optics. -- -- The goal of these functions is to provide an interoperability layer between -- the two styles of optics, and not to reimplement all the library in terms of -- 'Profunctor' optics. module Control.Lens.Profunctor ( -- * Profunctor optic OpticP -- * Conversion from Van Laarhoven optics , fromLens , fromIso , fromPrism , fromSetter , fromTraversal -- * Conversion to Van Laarhoven optics , toLens , toIso , toPrism , toSetter , toTraversal ) where import Prelude () import Control.Lens.Internal.Prelude import Control.Lens.Type (Optic, LensLike) import Control.Lens.Internal.Context (Context (..), sell) import Control.Lens.Internal.Profunctor (WrappedPafb (..)) import Control.Lens (ASetter, ATraversal, cloneTraversal, Settable) import Data.Profunctor (Star (..)) import Data.Profunctor.Mapping (Mapping (..)) import Data.Profunctor.Traversing (Traversing (..)) -- | Profunctor optic. type OpticP p s t a b = p a b -> p s t -------------------------------------------------------------------------------- -- Conversion from Van Laarhoven optics -------------------------------------------------------------------------------- -- | Converts a 'Control.Lens.Type.Lens' to a 'Profunctor'-based one. -- -- @ -- 'fromLens' :: 'Control.Lens.Type.Lens' s t a b -> LensP s t a b -- @ fromLens :: Strong p => LensLike (Context a b) s t a b -> OpticP p s t a b fromLens l p = dimap (\s -> let Context f a = l sell s in (f, a)) (uncurry id) (second' p) -- | Converts a 'Control.Lens.Type.Iso' to a 'Profunctor'-based one. -- -- @ -- 'fromIso' :: 'Control.Lens.Type.Iso' s t a b -> IsoP s t a b -- @ fromIso :: Profunctor p => Optic p Identity s t a b -> OpticP p s t a b fromIso p pab = rmap runIdentity (p (rmap Identity pab)) -- | Converts a 'Control.Lens.Type.Prism' to a 'Profunctor'-based one. -- -- @ -- 'fromPrism' :: 'Control.Lens.Type.Prism' s t a b -> PrismP s t a b -- @ fromPrism :: Choice p => Optic p Identity s t a b -> OpticP p s t a b fromPrism p pab = rmap runIdentity (p (rmap Identity pab)) -- | Converts a 'Control.Lens.Type.Setter' to a 'Profunctor'-based one. -- -- @ -- 'fromSetter' :: 'Control.Lens.Type.Setter' s t a b -> SetterP s t a b -- @ fromSetter :: Mapping p => ASetter s t a b -> OpticP p s t a b fromSetter s = roam s' where s' f = runIdentity . s (Identity . f) -- | Converts a 'Control.Lens.Type.Traversal' to a 'Profunctor'-based one. -- -- @ -- 'fromTraversal' :: 'Control.Lens.Type.Traversal' s t a b -> TraversalP s t a b -- @ fromTraversal :: Traversing p => ATraversal s t a b -> OpticP p s t a b fromTraversal l = wander (cloneTraversal l) -------------------------------------------------------------------------------- -- Conversion to Van Laarhoven optics -------------------------------------------------------------------------------- -- | Obtain a 'Control.Lens.Type.Prism' from a 'Profunctor'-based one. -- -- @ -- 'toPrism' :: PrismP s t a b -> 'Control.Lens.Type.Prism' s t a b -- @ toPrism :: (Choice p, Applicative f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b toPrism p = unwrapPafb . p . WrapPafb -- | Obtain a 'Control.Lens.Type.Iso' from a 'Profunctor'-based one. -- -- @ -- 'toIso' :: IsoP s t a b -> 'Control.Lens.Type.Iso' s t a b -- @ toIso :: (Profunctor p, Functor f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b toIso p = unwrapPafb . p . WrapPafb -- | Obtain a 'Control.Lens.Type.Lens' from a 'Profunctor'-based one. -- -- @ -- 'toLens' :: LensP s t a b -> 'Control.Lens.Type.Lens' s t a b -- @ toLens :: Functor f => OpticP (Star f) s t a b -> LensLike f s t a b toLens p = runStar . p . Star -- | Obtain a 'Control.Lens.Type.Setter' from a 'Profunctor'-based one. -- -- @ -- 'toSetter' :: SetterP s t a b -> 'Control.Lens.Type.Setter' s t a b -- @ toSetter :: Settable f => OpticP (Star f) s t a b -> LensLike f s t a b toSetter p = runStar . p . Star -- | Obtain a 'Control.Lens.Type.Traversal' from a 'Profunctor'-based one. -- -- @ -- 'toTraversal' :: TraversalP s t a b -> 'Control.Lens.Type.Traversal' s t a b -- @ toTraversal :: Applicative f => OpticP (Star f) s t a b -> LensLike f s t a b toTraversal p = runStar . p . Star lens-5.2.3/src/Control/Lens/Reified.hs0000644000000000000000000004176307346545000015701 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ -- | -- Module : Control.Lens.Reified -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ------------------------------------------------------------------------------ module Control.Lens.Reified where import Control.Applicative import Control.Arrow import qualified Control.Category as Cat import Control.Comonad import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal.Indexed import Control.Lens.Traversal (ignored) import Control.Lens.Type import Control.Monad import Control.Monad.Reader.Class import Data.Distributive import Data.Foldable import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Plus import Data.Profunctor.Closed import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Sieve #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif -- $setup -- >>> import Control.Lens -- >>> import Control.Applicative ------------------------------------------------------------------------------ -- Lens ------------------------------------------------------------------------------ -- | Reify a t'Lens' so it can be stored safely in a container. newtype ReifiedLens s t a b = Lens { runLens :: Lens s t a b } -- | @ -- type 'ReifiedLens'' = 'Simple' 'ReifiedLens' -- @ type ReifiedLens' s a = ReifiedLens s s a a ------------------------------------------------------------------------------ -- IndexedLens ------------------------------------------------------------------------------ -- | Reify an t'IndexedLens' so it can be stored safely in a container. newtype ReifiedIndexedLens i s t a b = IndexedLens { runIndexedLens :: IndexedLens i s t a b } -- | @ -- type 'ReifiedIndexedLens'' i = 'Simple' ('ReifiedIndexedLens' i) -- @ type ReifiedIndexedLens' i s a = ReifiedIndexedLens i s s a a ------------------------------------------------------------------------------ -- IndexedTraversal ------------------------------------------------------------------------------ -- | Reify an t'IndexedTraversal' so it can be stored safely in a container. newtype ReifiedIndexedTraversal i s t a b = IndexedTraversal { runIndexedTraversal :: IndexedTraversal i s t a b } -- | @ -- type 'ReifiedIndexedTraversal'' i = 'Simple' ('ReifiedIndexedTraversal' i) -- @ type ReifiedIndexedTraversal' i s a = ReifiedIndexedTraversal i s s a a ------------------------------------------------------------------------------ -- Traversal ------------------------------------------------------------------------------ -- | A form of t'Traversal' that can be stored monomorphically in a container. newtype ReifiedTraversal s t a b = Traversal { runTraversal :: Traversal s t a b } -- | @ -- type 'ReifiedTraversal'' = 'Simple' 'ReifiedTraversal' -- @ type ReifiedTraversal' s a = ReifiedTraversal s s a a ------------------------------------------------------------------------------ -- Getter ------------------------------------------------------------------------------ -- | Reify a t'Getter' so it can be stored safely in a container. -- -- This can also be useful when combining getters in novel ways, as -- 'ReifiedGetter' is isomorphic to '(->)' and provides similar instances. -- -- >>> ("hello","world","!!!")^.runGetter ((,) <$> Getter _2 <*> Getter (_1.to length)) -- ("world",5) newtype ReifiedGetter s a = Getter { runGetter :: Getter s a } instance Distributive (ReifiedGetter s) where distribute as = Getter $ to $ \s -> fmap (\(Getter l) -> view l s) as instance Functor (ReifiedGetter s) where fmap f l = Getter (runGetter l.to f) {-# INLINE fmap #-} instance Semigroup s => Extend (ReifiedGetter s) where duplicated (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (m <> n) {-# INLINE duplicated #-} instance Monoid s => Comonad (ReifiedGetter s) where extract (Getter l) = view l mempty {-# INLINE extract #-} duplicate (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (mappend m n) {-# INLINE duplicate #-} instance Monoid s => ComonadApply (ReifiedGetter s) where Getter mf <@> Getter ma = Getter $ to $ \s -> view mf s (view ma s) {-# INLINE (<@>) #-} m <@ _ = m {-# INLINE (<@) #-} _ @> m = m {-# INLINE (@>) #-} instance Apply (ReifiedGetter s) where Getter mf <.> Getter ma = Getter $ to $ \s -> view mf s (view ma s) {-# INLINE (<.>) #-} m <. _ = m {-# INLINE (<.) #-} _ .> m = m {-# INLINE (.>) #-} instance Applicative (ReifiedGetter s) where pure a = Getter $ to $ \_ -> a {-# INLINE pure #-} Getter mf <*> Getter ma = Getter $ to $ \s -> view mf s (view ma s) {-# INLINE (<*>) #-} m <* _ = m {-# INLINE (<*) #-} _ *> m = m {-# INLINE (*>) #-} instance Bind (ReifiedGetter s) where Getter ma >>- f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s {-# INLINE (>>-) #-} instance Monad (ReifiedGetter s) where return = pure {-# INLINE return #-} Getter ma >>= f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s {-# INLINE (>>=) #-} instance MonadReader s (ReifiedGetter s) where ask = Getter id {-# INLINE ask #-} local f m = Getter (to f . runGetter m) {-# INLINE local #-} instance Profunctor ReifiedGetter where dimap f g l = Getter $ to f.runGetter l.to g {-# INLINE dimap #-} lmap g l = Getter $ to g.runGetter l {-# INLINE lmap #-} rmap f l = Getter $ runGetter l.to f {-# INLINE rmap #-} instance Closed ReifiedGetter where closed l = Getter $ to $ \f -> view (runGetter l) . f instance Cosieve ReifiedGetter Identity where cosieve (Getter l) = view l . runIdentity instance Corepresentable ReifiedGetter where type Corep ReifiedGetter = Identity cotabulate f = Getter $ to (f . Identity) instance Sieve ReifiedGetter Identity where sieve (Getter l) = Identity . view l instance Representable ReifiedGetter where type Rep ReifiedGetter = Identity tabulate f = Getter $ to (runIdentity . f) instance Costrong ReifiedGetter where unfirst l = Getter $ to $ unfirst $ view (runGetter l) instance Conjoined ReifiedGetter instance Strong ReifiedGetter where first' l = Getter $ \f (s,c) -> phantom $ runGetter l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = Getter $ \f (c,s) -> phantom $ runGetter l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice ReifiedGetter where left' l = Getter $ to $ left' $ view $ runGetter l {-# INLINE left' #-} right' l = Getter $ to $ right' $ view $ runGetter l {-# INLINE right' #-} instance Cat.Category ReifiedGetter where id = Getter id l . r = Getter (runGetter r.runGetter l) {-# INLINE (.) #-} instance Arrow ReifiedGetter where arr f = Getter (to f) {-# INLINE arr #-} first l = Getter $ to $ first $ view $ runGetter l {-# INLINE first #-} second l = Getter $ to $ second $ view $ runGetter l {-# INLINE second #-} Getter l *** Getter r = Getter $ to $ view l *** view r {-# INLINE (***) #-} Getter l &&& Getter r = Getter $ to $ view l &&& view r {-# INLINE (&&&) #-} instance ArrowApply ReifiedGetter where app = Getter $ to $ \(Getter bc, b) -> view bc b {-# INLINE app #-} instance ArrowChoice ReifiedGetter where left l = Getter $ to $ left $ view $ runGetter l {-# INLINE left #-} right l = Getter $ to $ right $ view $ runGetter l {-# INLINE right #-} Getter l +++ Getter r = Getter $ to $ view l +++ view r {-# INLINE (+++) #-} Getter l ||| Getter r = Getter $ to $ view l ||| view r {-# INLINE (|||) #-} instance ArrowLoop ReifiedGetter where loop l = Getter $ to $ loop $ view $ runGetter l {-# INLINE loop #-} ------------------------------------------------------------------------------ -- IndexedGetter ------------------------------------------------------------------------------ -- | Reify an t'IndexedGetter' so it can be stored safely in a container. newtype ReifiedIndexedGetter i s a = IndexedGetter { runIndexedGetter :: IndexedGetter i s a } instance Profunctor (ReifiedIndexedGetter i) where dimap f g l = IndexedGetter (to f . runIndexedGetter l . to g) {-# INLINE dimap #-} instance Sieve (ReifiedIndexedGetter i) ((,) i) where sieve (IndexedGetter l) = iview l {-# INLINE sieve #-} instance Representable (ReifiedIndexedGetter i) where type Rep (ReifiedIndexedGetter i) = (,) i tabulate f = IndexedGetter $ ito f {-# INLINE tabulate #-} instance Strong (ReifiedIndexedGetter i) where first' l = IndexedGetter $ \f (s,c) -> phantom $ runIndexedGetter l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = IndexedGetter $ \f (c,s) -> phantom $ runIndexedGetter l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Functor (ReifiedIndexedGetter i s) where fmap f l = IndexedGetter (runIndexedGetter l.to f) {-# INLINE fmap #-} instance Semigroup i => Apply (ReifiedIndexedGetter i s) where IndexedGetter mf <.> IndexedGetter ma = IndexedGetter $ \k s -> case iview mf s of (i, f) -> case iview ma s of (j, a) -> phantom $ indexed k (i <> j) (f a) {-# INLINE (<.>) #-} ------------------------------------------------------------------------------ -- Fold ------------------------------------------------------------------------------ -- | Reify a t'Fold' so it can be stored safely in a container. -- -- This can also be useful for creatively combining folds as -- @'ReifiedFold' s@ is isomorphic to @ReaderT s []@ and provides similar -- instances. -- -- >>> ("hello","world")^..runFold ((,) <$> Fold _2 <*> Fold both) -- [("world","hello"),("world","world")] newtype ReifiedFold s a = Fold { runFold :: Fold s a } instance Profunctor ReifiedFold where dimap f g l = Fold (to f . runFold l . to g) {-# INLINE dimap #-} rmap g l = Fold (runFold l . to g) {-# INLINE rmap #-} lmap f l = Fold (to f . runFold l) {-# INLINE lmap #-} instance Sieve ReifiedFold [] where sieve (Fold l) = toListOf l instance Representable ReifiedFold where type Rep ReifiedFold = [] tabulate f = Fold (folding f) instance Strong ReifiedFold where first' l = Fold $ \f (s,c) -> phantom $ runFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = Fold $ \f (c,s) -> phantom $ runFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice ReifiedFold where left' (Fold l) = Fold $ folding $ \esc -> case esc of Left s -> Left <$> toListOf l s Right c -> [Right c] {-# INLINE left' #-} right' (Fold l) = Fold $ folding $ \ecs -> case ecs of Left c -> [Left c] Right s -> Right <$> toListOf l s {-# INLINE right' #-} instance Cat.Category ReifiedFold where id = Fold id l . r = Fold (runFold r . runFold l) {-# INLINE (.) #-} instance Arrow ReifiedFold where arr f = Fold (to f) {-# INLINE arr #-} first = first' {-# INLINE first #-} second = second' {-# INLINE second #-} Fold l *** Fold r = Fold $ folding $ \(x,y) -> (,) <$> toListOf l x <*> toListOf r y {-# INLINE (***) #-} Fold l &&& Fold r = Fold $ folding $ \x -> (,) <$> toListOf l x <*> toListOf r x {-# INLINE (&&&) #-} instance ArrowChoice ReifiedFold where left = left' {-# INLINE left #-} right = right' {-# INLINE right #-} instance ArrowApply ReifiedFold where app = Fold $ folding $ \(Fold bc, b) -> toListOf bc b {-# INLINE app #-} instance Functor (ReifiedFold s) where fmap f l = Fold (runFold l.to f) {-# INLINE fmap #-} instance Apply (ReifiedFold s) where Fold mf <.> Fold ma = Fold $ folding $ \s -> toListOf mf s <.> toListOf ma s {-# INLINE (<.>) #-} Fold mf <. Fold ma = Fold $ folding $ \s -> toListOf mf s <. toListOf ma s {-# INLINE (<.) #-} Fold mf .> Fold ma = Fold $ folding $ \s -> toListOf mf s .> toListOf ma s {-# INLINE (.>) #-} instance Applicative (ReifiedFold s) where pure a = Fold $ folding $ \_ -> [a] {-# INLINE pure #-} Fold mf <*> Fold ma = Fold $ folding $ \s -> toListOf mf s <*> toListOf ma s {-# INLINE (<*>) #-} Fold mf <* Fold ma = Fold $ folding $ \s -> toListOf mf s <* toListOf ma s {-# INLINE (<*) #-} Fold mf *> Fold ma = Fold $ folding $ \s -> toListOf mf s *> toListOf ma s {-# INLINE (*>) #-} instance Alternative (ReifiedFold s) where empty = Fold ignored {-# INLINE empty #-} Fold ma <|> Fold mb = Fold $ folding (\s -> toListOf ma s ++ toListOf mb s) {-# INLINE (<|>) #-} instance Bind (ReifiedFold s) where Fold ma >>- f = Fold $ folding $ \s -> toListOf ma s >>- \a -> toListOf (runFold (f a)) s {-# INLINE (>>-) #-} instance Monad (ReifiedFold s) where return = pure {-# INLINE return #-} Fold ma >>= f = Fold $ folding $ \s -> toListOf ma s >>= \a -> toListOf (runFold (f a)) s {-# INLINE (>>=) #-} instance MonadPlus (ReifiedFold s) where mzero = empty {-# INLINE mzero #-} mplus = (<|>) {-# INLINE mplus #-} instance MonadReader s (ReifiedFold s) where ask = Fold id {-# INLINE ask #-} local f m = Fold (to f . runFold m) {-# INLINE local #-} instance Semigroup (ReifiedFold s a) where (<>) = (<|>) {-# INLINE (<>) #-} instance Monoid (ReifiedFold s a) where mempty = Fold ignored {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend = (<|>) {-# INLINE mappend #-} #endif instance Alt (ReifiedFold s) where () = (<|>) {-# INLINE () #-} instance Plus (ReifiedFold s) where zero = Fold ignored {-# INLINE zero #-} ------------------------------------------------------------------------------ -- IndexedFold ------------------------------------------------------------------------------ newtype ReifiedIndexedFold i s a = IndexedFold { runIndexedFold :: IndexedFold i s a } instance Semigroup (ReifiedIndexedFold i s a) where (<>) = () {-# INLINE (<>) #-} instance Monoid (ReifiedIndexedFold i s a) where mempty = IndexedFold ignored {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend = () {-# INLINE mappend #-} #endif instance Alt (ReifiedIndexedFold i s) where IndexedFold ma IndexedFold mb = IndexedFold $ ifolding $ \s -> itoListOf ma s ++ itoListOf mb s {-# INLINE () #-} instance Plus (ReifiedIndexedFold i s) where zero = IndexedFold ignored {-# INLINE zero #-} instance Functor (ReifiedIndexedFold i s) where fmap f l = IndexedFold (runIndexedFold l . to f) {-# INLINE fmap #-} instance Profunctor (ReifiedIndexedFold i) where dimap f g l = IndexedFold (to f . runIndexedFold l . to g) {-# INLINE dimap #-} lmap f l = IndexedFold (to f . runIndexedFold l) {-# INLINE lmap #-} rmap g l = IndexedFold (runIndexedFold l . to g) {-# INLINE rmap #-} instance Sieve (ReifiedIndexedFold i) (Compose [] ((,) i)) where sieve (IndexedFold l) = Compose . itoListOf l {-# INLINE sieve #-} instance Representable (ReifiedIndexedFold i) where type Rep (ReifiedIndexedFold i) = Compose [] ((,) i) tabulate k = IndexedFold $ \f -> phantom . traverse_ (phantom . uncurry (indexed f)) . getCompose . k {-# INLINE tabulate #-} instance Strong (ReifiedIndexedFold i) where first' l = IndexedFold $ \f (s,c) -> phantom $ runIndexedFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = IndexedFold $ \f (c,s) -> phantom $ runIndexedFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} ------------------------------------------------------------------------------ -- Setter ------------------------------------------------------------------------------ -- | Reify a t'Setter' so it can be stored safely in a container. newtype ReifiedSetter s t a b = Setter { runSetter :: Setter s t a b } -- | @ -- type 'ReifiedSetter'' = 'Simple' 'ReifiedSetter' -- @ type ReifiedSetter' s a = ReifiedSetter s s a a ------------------------------------------------------------------------------ -- IndexedSetter ------------------------------------------------------------------------------ -- | Reify an t'IndexedSetter' so it can be stored safely in a container. newtype ReifiedIndexedSetter i s t a b = IndexedSetter { runIndexedSetter :: IndexedSetter i s t a b } -- | @ -- type 'ReifiedIndexedSetter'' i = 'Simple' ('ReifiedIndexedSetter' i) -- @ type ReifiedIndexedSetter' i s a = ReifiedIndexedSetter i s s a a ------------------------------------------------------------------------------ -- Iso ------------------------------------------------------------------------------ -- | Reify an t'Iso' so it can be stored safely in a container. newtype ReifiedIso s t a b = Iso { runIso :: Iso s t a b } -- | @ -- type 'ReifiedIso'' = 'Simple' 'ReifiedIso' -- @ type ReifiedIso' s a = ReifiedIso s s a a ------------------------------------------------------------------------------ -- Prism ------------------------------------------------------------------------------ -- | Reify a t'Prism' so it can be stored safely in a container. newtype ReifiedPrism s t a b = Prism { runPrism :: Prism s t a b } -- | @ -- type 'ReifiedPrism'' = 'Simple' 'ReifiedPrism' -- @ type ReifiedPrism' s a = ReifiedPrism s s a a lens-5.2.3/src/Control/Lens/Review.hs0000644000000000000000000001621007346545000015560 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -Wno-redundant-constraints -Wno-trustworthy-safe #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Review -- Copyright : (C) 2012-16 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 , AReview , unto , un , re , review, reviews , reuse, reuses , (#) , Bifunctor(bimap) , retagged , Reviewable , reviewing ) 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.Type import Data.Bifunctor import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Unsafe import Data.Tagged import Data.Void -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Numeric.Lens -- >>> import Data.Semigroup (Semigroup (..)) -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False infixr 8 # ------------------------------------------------------------------------------ -- Review ------------------------------------------------------------------------------ -- | An analogue of 'to' for 'review'. -- -- @ -- 'unto' :: (b -> t) -> 'Review'' t b -- @ -- -- @ -- 'unto' = 'un' . 'to' -- @ unto :: (Profunctor p, Bifunctor p, Functor f) => (b -> t) -> Optic p f s t a b unto f = first absurd . lmap absurd . rmap (fmap f) {-# INLINE unto #-} -- | Turn a 'Getter' around to get a 'Review' -- -- @ -- 'un' = 'unto' . 'view' -- 'unto' = 'un' . 'to' -- @ -- -- >>> un (to length) # [1,2,3] -- 3 un :: (Profunctor p, Bifunctor p, Functor f) => Getting a s a -> Optic' p f a s un = unto . view -- | Turn a 'Prism' or 'Control.Lens.Iso.Iso' around to build a 'Getter'. -- -- If you have an 'Control.Lens.Iso.Iso', 'Control.Lens.Iso.from' is a more powerful version of this function -- 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 t b -> Getter b t re p = to (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE re #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way. -- -- @ -- '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 -- it may be beneficial to think of it as having one of these slightly more liberal type signatures: -- -- @ -- 'review' :: 'MonadReader' a m => 'Iso'' s a -> m s -- 'review' :: 'MonadReader' a m => 'Prism'' s a -> m s -- @ review :: MonadReader b m => AReview t b -> m t review p = asks (runIdentity #. unTagged #. p .# Tagged .# 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 t b -> b -> t (#) p = runIdentity #. unTagged #. p .# Tagged .# Identity {-# INLINE (#) #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way, -- 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 -- it may be beneficial to think of it as having one of these slightly more liberal type signatures: -- -- @ -- '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 t b -> (t -> r) -> m r reviews p tr = asks (tr . runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE reviews #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' a value (or the current environment) through it the other way. -- -- @ -- '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 t b -> m t reuse p = gets (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE reuse #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' the current state through it the other way, -- 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 t b -> (t -> r) -> m r reuses p tr = gets (tr . runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE reuses #-} -- | Coerce a polymorphic 'Prism' to a 'Review'. -- -- @ -- 'reviewing' :: 'Iso' s t a b -> 'Review' t b -- 'reviewing' :: 'Prism' s t a b -> 'Review' t b -- @ reviewing :: (Bifunctor p, Functor f) => Optic Tagged Identity s t a b -> Optic' p f t b reviewing p = bimap f (fmap f) where f = runIdentity . unTagged . p . Tagged . Identity lens-5.2.3/src/Control/Lens/Setter.hs0000644000000000000000000012646107346545000015577 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Setter -- Copyright : (C) 2012-16 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.Functor.Contravariant (Predicate (..), Op (..)) -- >>> import qualified Data.Map as Map -- >>> import Data.Semigroup (Sum (..), Product (..), Semigroup (..)) -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> 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" -- >>> :set -XNoOverloadedStrings infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, =, ||=, %=, <.=, ?=, Identity b) -> s -> Identity 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. type AnIndexedSetter i s t a b = Indexed i a (Identity b) -> s -> Identity 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 (Identity b) -> s -> Identity t -- | This is a convenient alias when defining highly polymorphic code that takes both -- 'ASetter'' and 'AnIndexedSetter'' as appropriate. If a function takes this it is -- 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' was not a superclass of 'Monad' until -- GHC 7.10. -- -- @ -- '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 . _Unwrapping' 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 (cosieve 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) -> Optical p q f s t a b sets f g = taintedDot (f (untaintedDot g)) {-# INLINE sets #-} -- | Restore 'ASetter' to a full 'Setter'. cloneSetter :: ASetter s t a b -> Setter s t a b cloneSetter l afb = taintedDot $ coerce l (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 runIdentity $ l (\a -> Identity (untainted (cosieve 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 (runIdentity #. l (Indexed $ \i -> Identity #. 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 :: ASetter s t a b -> (a -> b) -> s -> t over = coerce {-# 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 = runIdentity #. l (\_ -> Identity 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 = runIdentity #. l (\_ -> Identity 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 -- @ (%~) :: ASetter s t a b -> (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)] -- -- '?~' can be used type-changily: -- -- >>> ('a', ('b', 'c')) & _2.both ?~ 'x' -- ('a',(Just 'x',Just '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 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 qualified 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 **~ 10 $ (3,2) -- (3,1024.0) -- -- @ -- ('**~') :: '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 () -- @ (%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () l %= f = State.modify (l %~ f) {-# INLINE (%=) #-} -- | This is an alias for ('%='). modifying :: MonadState s m => ASetter s s a b -> (a -> b) -> m () modifying l f = State.modify (over l f) {-# INLINE modifying #-} -- | 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!!!") -- -- @ -- ('<>~') :: 'Semigroup' a => 'Setter' s t a a -> a -> s -> t -- ('<>~') :: 'Semigroup' a => 'Iso' s t a a -> a -> s -> t -- ('<>~') :: 'Semigroup' a => 'Lens' s t a a -> a -> s -> t -- ('<>~') :: 'Semigroup' a => 'Traversal' s t a a -> a -> s -> t -- @ (<>~) :: Semigroup a => ASetter s t a a -> a -> s -> t l <>~ n = over l (<> n) {-# INLINE (<>~) #-} -- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('<>')@. -- -- >>> 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, 'Semigroup' a) => 'Setter'' s a -> a -> m () -- ('<>=') :: ('MonadState' s m, 'Semigroup' a) => 'Iso'' s a -> a -> m () -- ('<>=') :: ('MonadState' s m, 'Semigroup' a) => 'Lens'' s a -> a -> m () -- ('<>=') :: ('MonadState' s m, 'Semigroup' a) => 'Traversal'' s a -> a -> m () -- @ (<>=) :: (MonadState s m, Semigroup 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 allows 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 allows 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 allows 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 allows 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 #-} ----------------------------------------------------------------------------- -- Reader Operations ----------------------------------------------------------------------------- -- | Modify the value of the 'Reader' environment associated with the target of a -- 'Setter', 'Lens', or 'Traversal'. -- -- @ -- 'locally' l 'id' a ≡ a -- 'locally' l f '.' locally l g ≡ 'locally' l (f '.' g) -- @ -- -- >>> (1,1) & locally _1 (+1) (uncurry (+)) -- 3 -- -- >>> "," & locally ($) ("Hello" <>) (<> " world!") -- "Hello, world!" -- -- @ -- locally :: MonadReader s m => 'Iso' s s a b -> (a -> b) -> m r -> m r -- locally :: MonadReader s m => 'Lens' s s a b -> (a -> b) -> m r -> m r -- locally :: MonadReader s m => 'Traversal' s s a b -> (a -> b) -> m r -> m r -- locally :: MonadReader s m => 'Setter' s s a b -> (a -> b) -> m r -> m r -- @ locally :: MonadReader s m => ASetter s s a b -> (a -> b) -> m r -> m r locally l f = Reader.local (over l f) {-# INLINE locally #-} -- | This is a generalization of 'locally' that allows one to make indexed -- 'local' changes to a 'Reader' environment associated with the target of a -- 'Setter', 'Lens', or 'Traversal'. -- -- @ -- 'locally' l f ≡ 'ilocally' l f . const -- 'ilocally' l f ≡ 'locally' l f . 'Indexed' -- @ -- -- @ -- ilocally :: MonadReader s m => 'IndexedLens' s s a b -> (i -> a -> b) -> m r -> m r -- ilocally :: MonadReader s m => 'IndexedTraversal' s s a b -> (i -> a -> b) -> m r -> m r -- ilocally :: MonadReader s m => 'IndexedSetter' s s a b -> (i -> a -> b) -> m r -> m r -- @ ilocally :: MonadReader s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m r -> m r ilocally l f = Reader.local (iover l f) {-# INLINE ilocally #-} ----------------------------------------------------------------------------- -- 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 = coerce {-# INLINE iover #-} -- | Set with index. Equivalent to 'iover' with the current value ignored. -- -- When you do not need access to the index, then 'set' is more liberal in what it can accept. -- -- @ -- 'set' l ≡ 'iset' l '.' 'const' -- @ -- -- @ -- 'iset' :: 'IndexedSetter' i s t a b -> (i -> b) -> s -> t -- 'iset' :: 'IndexedLens' i s t a b -> (i -> b) -> s -> t -- 'iset' :: 'IndexedTraversal' i s t a b -> (i -> b) -> s -> t -- @ iset :: AnIndexedSetter i s t a b -> (i -> b) -> s -> t iset l = iover l . (const .) {-# INLINE iset #-} -- | 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 'isets' is that it takes a \"semantic editor combinator\" -- which has been modified to carry an index and transforms it into a 'IndexedSetter'. 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. -- -- @ -- ('%@~') ≡ 'iover' -- @ -- -- 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 (%@~) = iover {-# INLINE (%@~) #-} -- | Replace every target of an 'IndexedSetter', 'IndexedLens' or 'IndexedTraversal' -- with access to the index. -- -- @ -- ('.@~') ≡ 'iset' -- @ -- -- When you do not need access to the index then ('.~') is more liberal in what it can accept. -- -- @ -- l '.~' b ≡ l '.@~' 'const' b -- @ -- -- @ -- ('.@~') :: 'IndexedSetter' i s t a b -> (i -> b) -> s -> t -- ('.@~') :: 'IndexedLens' i s t a b -> (i -> b) -> s -> t -- ('.@~') :: 'IndexedTraversal' i s t a b -> (i -> b) -> s -> t -- @ (.@~) :: AnIndexedSetter i s t a b -> (i -> b) -> s -> t l .@~ f = runIdentity #. l (Identity #. Indexed (const . 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 (%@=) #-} -- | This is an alias for ('%@='). imodifying :: MonadState s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m () imodifying l f = State.modify (iover l f) {-# INLINE imodifying #-} -- | Replace 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 '.=' b ≡ l '.@=' 'const' b -- @ -- -- @ -- ('.@=') :: 'MonadState' s m => 'IndexedSetter' i s s a b -> (i -> b) -> m () -- ('.@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> b) -> m () -- ('.@=') :: 'MonadState' s m => 'IndexedTraversal' i s t a b -> (i -> b) -> m () -- @ (.@=) :: MonadState s m => AnIndexedSetter i s s a b -> (i -> b) -> m () l .@= f = State.modify (l .@~ f) {-# INLINE (.@=) #-} ------------------------------------------------------------------------------ -- Arrows ------------------------------------------------------------------------------ -- | Run an arrow command and use the output to set all the targets of -- a 'Lens', 'Setter' or 'Traversal' to the result. -- -- 'assignA' can be used very similarly to ('<~'), except that the type of -- the object being modified can change; for example: -- -- @ -- runKleisli action ((), (), ()) where -- action = assignA _1 (Kleisli (const getVal1)) -- \>>> assignA _2 (Kleisli (const getVal2)) -- \>>> assignA _3 (Kleisli (const getVal3)) -- getVal1 :: Either String Int -- getVal1 = ... -- getVal2 :: Either String Bool -- getVal2 = ... -- getVal3 :: Either String Char -- getVal3 = ... -- @ -- -- has the type @'Either' 'String' ('Int', 'Bool', 'Char')@ -- -- @ -- 'assignA' :: 'Arrow' p => 'Iso' s t a b -> p s b -> p s t -- 'assignA' :: 'Arrow' p => 'Lens' s t a b -> p s b -> p s t -- 'assignA' :: 'Arrow' p => 'Traversal' s t a b -> p s b -> p s t -- 'assignA' :: 'Arrow' p => 'Setter' s t a b -> p s b -> p s t -- @ assignA :: Arrow p => ASetter s t a b -> p s b -> p s t assignA l p = arr (flip $ set l) &&& p >>> arr (uncurry id) {-# INLINE assignA #-} ------------------------------------------------------------------------------ -- Deprecated ------------------------------------------------------------------------------ -- | 'mapOf' is a deprecated alias for 'over'. mapOf :: ASetter s t a b -> (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-5.2.3/src/Control/Lens/TH.hs0000644000000000000000000006414707346545000014646 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} #ifdef TRUSTWORTHY # if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-} # else {-# LANGUAGE Trustworthy #-} # endif #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.TH -- Copyright : (C) 2012-16 Edward Kmett, 2012-13 Michael Sloan -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Control.Lens.TH ( -- * Constructing Lenses Automatically -- ** Lenses for data fields makeLenses, makeLensesFor , makeClassy, makeClassyFor, makeClassy_ , makeFields , makeFieldsNoPrefix -- ** Prisms , makePrisms , makeClassyPrisms -- ** Wrapped , makeWrapped -- * Constructing Lenses Given a Declaration Quote -- ** Lenses for data fields , declareLenses, declareLensesFor , declareClassy, declareClassyFor , declareFields -- ** Prisms , declarePrisms -- ** Wrapped , declareWrapped -- * Configuring Lenses -- ** Running LensRules , makeLensesWith , declareLensesWith -- ** LensRules type , LensRules -- ** Predefined LensRules , lensRules , lensRulesFor , classyRules , classyRules_ , defaultFieldRules , camelCaseFields , classUnderscoreNoPrefixFields , underscoreFields , abbreviatedFields -- ** LensRules configuration accessors , lensField , FieldNamer , DefName(..) , lensClass , ClassyNamer , simpleLenses , createClass , generateSignatures , generateUpdateableOptics , generateLazyPatterns , generateRecordSyntax -- ** FieldNamers , underscoreNoPrefixNamer , lookingupNamer , mappingNamer , camelCaseNamer , classUnderscoreNoPrefixNamer , underscoreNamer , abbreviatedNamer ) where import Prelude () import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.Trans.Writer import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Internal.Prelude as Prelude import Control.Lens.Internal.TH import Control.Lens.Internal.FieldTH import Control.Lens.Internal.PrismTH import Control.Lens.Wrapped () -- haddocks import Control.Lens.Type () -- haddocks import Data.Char (toLower, toUpper, isUpper) import Data.Foldable hiding (concat, any) import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (maybeToList) import qualified Data.Set as Set import Data.Set (Set) import Data.Traversable hiding (mapM) import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lens import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax hiding (lift) -- | Generate "simple" optics even when type-changing optics are possible. -- (e.g. 'Lens'' instead of 'Lens') simpleLenses :: Lens' LensRules Bool simpleLenses f r = fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r)) -- | 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 f r = fmap (\x -> r { _generateSigs = x}) (f (_generateSigs r)) -- | Generate "updateable" optics when 'True'. When 'False', 'Fold's will be -- generated instead of 'Traversal's and 'Getter's will be generated instead -- of 'Lens'es. This mode is intended to be used for types with invariants -- which must be maintained by "smart" constructors. generateUpdateableOptics :: Lens' LensRules Bool generateUpdateableOptics f r = fmap (\x -> r { _allowUpdates = x}) (f (_allowUpdates r)) -- | Generate optics using lazy pattern matches. This can -- allow fields of an undefined value to be initialized with lenses: -- -- @ -- data Foo = Foo {_x :: Int, _y :: Bool} -- deriving Show -- -- 'makeLensesWith' ('lensRules' & 'generateLazyPatterns' .~ True) ''Foo -- @ -- -- @ -- > undefined & x .~ 8 & y .~ True -- Foo {_x = 8, _y = True} -- @ -- -- The downside of this flag is that it can lead to space-leaks and -- code-size/compile-time increases when generated for large records. By -- default this flag is turned off, and strict optics are generated. -- -- When using lazy optics the strict optic can be recovered by composing -- with '$!': -- -- @ -- strictOptic = ($!) . lazyOptic -- @ generateLazyPatterns :: Lens' LensRules Bool generateLazyPatterns f r = fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r)) generateRecordSyntax :: Lens' LensRules Bool generateRecordSyntax f r = fmap (\x -> r {_recordSyntax = x}) (f (_recordSyntax r)) -- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the -- 'lensClass' rule matches. createClass :: Lens' LensRules Bool createClass f r = fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r)) -- | 'Lens'' to access the convention for naming fields in our 'LensRules'. lensField :: Lens' LensRules FieldNamer lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r)) -- | 'Lens'' to access the option for naming "classy" lenses. lensClass :: Lens' LensRules ClassyNamer lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r)) -- | Rules for making fairly simple partial lenses, ignoring the special cases -- for isomorphisms and traversals, and not making any classes. -- It uses 'underscoreNoPrefixNamer'. lensRules :: LensRules lensRules = LensRules { _simpleLenses = False , _generateSigs = True , _generateClasses = False , _allowIsos = True , _allowUpdates = True , _lazyPatterns = False , _recordSyntax = False , _classyLenses = const Nothing , _fieldToDef = underscoreNoPrefixNamer } -- | A 'FieldNamer' that strips the _ off of the field name, -- lowercases the name, and skips the field if it doesn't start with -- an '_'. underscoreNoPrefixNamer :: FieldNamer underscoreNoPrefixNamer _ _ n = case nameBase n of '_':x:xs -> [TopName (mkName (toLower x:xs))] _ -> [] -- | Construct a 'LensRules' value for generating top-level definitions -- using the given map from field names to definition names. lensRulesFor :: [(String, String)] {- ^ [(Field Name, Definition Name)] -} -> LensRules lensRulesFor fields = lensRules & lensField .~ lookingupNamer fields -- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@. lookingupNamer :: [(String,String)] -> FieldNamer lookingupNamer kvs _ _ field = [ TopName (mkName v) | (k,v) <- kvs, k == nameBase field] -- | Create a 'FieldNamer' from a mapping function. If the function -- returns @[]@, it creates no lens for the field. mappingNamer :: (String -> [String]) -- ^ A function that maps a @fieldName@ to @lensName@s. -> FieldNamer mappingNamer mapper _ _ = fmap (TopName . mkName) . mapper . nameBase -- | Rules for making lenses and traversals that precompose another 'Lens'. classyRules :: LensRules classyRules = LensRules { _simpleLenses = True , _generateSigs = True , _generateClasses = True , _allowIsos = False -- generating Isos would hinder "subtyping" , _allowUpdates = True , _lazyPatterns = False , _recordSyntax = False , _classyLenses = \n -> case nameBase n of x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs)) [] -> Nothing , _fieldToDef = underscoreNoPrefixNamer } -- | Rules for making lenses and traversals that precompose another 'Lens' -- using a custom function for naming the class, main class method, and a -- mapping from field names to definition names. classyRulesFor :: (String -> Maybe (String, String)) {- ^ Type Name -> Maybe (Class Name, Method Name) -} -> [(String, String)] {- ^ [(Field Name, Method Name)] -} -> LensRules classyRulesFor classFun fields = classyRules & lensClass .~ (over (mapped . both) mkName . classFun . nameBase) & lensField .~ lookingupNamer fields -- | A 'LensRules' used by 'makeClassy_'. classyRules_ :: LensRules classyRules_ = classyRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))] -- | Build lenses (and traversals) with a sensible default configuration. -- -- /e.g./ -- -- @ -- data FooBar -- = Foo { _x, _y :: 'Int' } -- | Bar { _x :: 'Int' } -- 'makeLenses' ''FooBar -- @ -- -- will create -- -- @ -- x :: 'Lens'' FooBar 'Int' -- x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a -- x f (Bar a) = Bar \<$\> f a -- y :: 'Traversal'' FooBar 'Int' -- y f (Foo a b) = (\\b\' -> Foo a b\') \<$\> f b -- y _ c\@(Bar _) = pure c -- @ -- -- @ -- 'makeLenses' = 'makeLensesWith' 'lensRules' -- @ makeLenses :: Name -> DecsQ makeLenses = makeFieldOptics 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 :: 'Lens'' t Foo -- fooX :: 'Lens'' t 'Int' -- fooX = foo . go where go f (Foo x y) = (\\x\' -> Foo x' y) \<$\> f x -- fooY :: 'Lens'' t 'Int' -- fooY = foo . go where go f (Foo x y) = (\\y\' -> Foo x y') \<$\> f y -- instance HasFoo Foo where -- foo = id -- @ -- -- @ -- 'makeClassy' = 'makeLensesWith' 'classyRules' -- @ makeClassy :: Name -> DecsQ makeClassy = makeFieldOptics classyRules -- | Make lenses and traversals for a type, and create a class when the type -- has no arguments. Works the same as 'makeClassy' except that (a) it -- expects that record field names do not begin with an underscore, (b) all -- record fields are made into lenses, and (c) the resulting lens is prefixed -- with an underscore. makeClassy_ :: Name -> DecsQ makeClassy_ = makeFieldOptics classyRules_ -- | 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 -> DecsQ makeLensesFor fields = makeFieldOptics (lensRulesFor 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 -> DecsQ makeClassyFor clsName funName fields = makeFieldOptics $ classyRulesFor (const (Just (clsName, funName))) fields -- | Build lenses with a custom configuration. makeLensesWith :: LensRules -> Name -> DecsQ makeLensesWith = makeFieldOptics -- | Make lenses for all records in the given declaration quote. All record -- syntax in the input will be stripped off. -- -- /e.g./ -- -- @ -- declareLenses [d| -- data Foo = Foo { fooX, fooY :: 'Int' } -- deriving 'Show' -- |] -- @ -- -- will create -- -- @ -- data Foo = Foo 'Int' 'Int' deriving 'Show' -- fooX, fooY :: 'Lens'' Foo Int -- @ declareLenses :: DecsQ -> DecsQ declareLenses = declareLensesWith $ lensRules & lensField .~ \_ _ n -> [TopName n] -- | Similar to 'makeLensesFor', but takes a declaration quote. declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ declareLensesFor fields = declareLensesWith $ lensRulesFor fields & lensField .~ \_ _ n -> [TopName n] -- | For each record in the declaration quote, make lenses and traversals for -- it, and create a class when the type has no arguments. All record syntax -- in the input will be stripped off. -- -- /e.g./ -- -- @ -- declareClassy [d| -- data Foo = Foo { fooX, fooY :: 'Int' } -- deriving 'Show' -- |] -- @ -- -- will create -- -- @ -- data Foo = Foo 'Int' 'Int' deriving 'Show' -- class HasFoo t where -- foo :: 'Lens'' t Foo -- instance HasFoo Foo where foo = 'id' -- fooX, fooY :: HasFoo t => 'Lens'' t 'Int' -- @ declareClassy :: DecsQ -> DecsQ declareClassy = declareLensesWith $ classyRules & lensField .~ \_ _ n -> [TopName n] -- | Similar to 'makeClassyFor', but takes a declaration quote. declareClassyFor :: [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ declareClassyFor classes fields = declareLensesWith $ classyRulesFor (`Prelude.lookup`classes) fields & lensField .~ \_ _ n -> [TopName n] -- | Generate a 'Control.Lens.Type.Prism' for each constructor of each data type. -- -- /e.g./ -- -- @ -- declarePrisms [d| -- data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp } -- |] -- @ -- -- will create -- -- @ -- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp } -- _Lit :: 'Prism'' Exp Int -- _Var :: 'Prism'' Exp String -- _Lambda :: 'Prism'' Exp (String, Exp) -- @ declarePrisms :: DecsQ -> DecsQ declarePrisms = declareWith $ \dec -> do emit =<< liftDeclare (makeDecPrisms True dec) return dec -- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype. declareWrapped :: DecsQ -> DecsQ declareWrapped = declareWith $ \dec -> do maybeDecs <- liftDeclare $ do inf <- normalizeDec dec makeWrappedForDatatypeInfo inf forM_ maybeDecs emit return dec -- | @ declareFields = 'declareLensesWith' 'defaultFieldRules' @ declareFields :: DecsQ -> DecsQ declareFields = declareLensesWith defaultFieldRules -- | Declare lenses for each records in the given declarations, using the -- specified 'LensRules'. Any record syntax in the input will be stripped -- off. declareLensesWith :: LensRules -> DecsQ -> DecsQ declareLensesWith rules = declareWith $ \dec -> do emit =<< lift (makeFieldOpticsForDec' rules dec) return $ stripFields dec ----------------------------------------------------------------------------- -- Internal TH Implementation ----------------------------------------------------------------------------- -- | 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)) apps :: Type -> [Type] -> Type apps = Prelude.foldl AppT -- | Build 'Wrapped' instance for a given newtype makeWrapped :: Name -> DecsQ makeWrapped nm = do inf <- reifyDatatype nm maybeDecs <- makeWrappedForDatatypeInfo inf maybe (fail "makeWrapped: Unsupported data type") return maybeDecs makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec]) makeWrappedForDatatypeInfo dataInfo@(DatatypeInfo{datatypeCons = cons}) | [conInfo@(ConstructorInfo{constructorFields = fields})] <- cons , [field] <- fields = do wrapped <- makeWrappedInstance dataInfo conInfo field rewrapped <- makeRewrappedInstance dataInfo return (Just [rewrapped, wrapped]) | otherwise = return Nothing makeRewrappedInstance :: DatatypeInfo -> DecQ makeRewrappedInstance dataInfo = do t <- varT <$> newName "t" let typeArgs = map (view name) (datatypeVars dataInfo) typeArgs' <- do m <- freshMap (Set.fromList typeArgs) return (substTypeVars m typeArgs) -- Con a b c... let appliedType = return (applyDatatypeToArgs dataInfo (map VarT typeArgs)) -- Con a' b' c'... appliedType' = return (applyDatatypeToArgs dataInfo (map VarT typeArgs')) -- Con a' b' c'... ~ t eq = AppT. AppT EqualityT <$> appliedType' <*> t -- Rewrapped (Con a b c...) t klass = conT rewrappedTypeName `appsT` [appliedType, t] -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t instanceD (cxt [eq]) klass [] makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ makeWrappedInstance dataInfo conInfo fieldType = do let conName = constructorName conInfo let typeArgs = toListOf typeVars (datatypeVars dataInfo) -- Con a b c... let appliedType = applyDatatypeToArgs dataInfo (map VarT typeArgs) -- type Unwrapped (Con a b c...) = $fieldType let unwrappedATF = tySynInstDCompat unwrappedTypeName Nothing [return appliedType] (return fieldType) -- Wrapped (Con a b c...) let klass = conT wrappedTypeName `appT` return appliedType -- _Wrapped' = iso (\(Con x) -> x) Con let wrapFun = conE conName let unwrapFun = newName "x" >>= \x -> lam1E (conP conName [varP x]) (varE x) let body = appsE [varE isoValName, unwrapFun, wrapFun] let isoMethod = funD _wrapped'ValName [clause [] (normalB body) []] -- instance Wrapped (Con a b c...) where -- type Unwrapped (Con a b c...) = fieldType -- _Wrapped' = iso (\(Con x) -> x) Con instanceD (cxt []) klass [unwrappedATF, isoMethod] -- | Apply the 'datatypeName' of a 'DatatypeInfo' to some argument 'Type's, -- which are used to instantiate its 'datatypeVars'. applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type applyDatatypeToArgs di@(DatatypeInfo { datatypeName = nm , datatypeVars = vars , datatypeInstTypes = instTypes }) args = apps (ConT nm) $ -- Drop kind signatures if possible to reduce the likelihood of needing to -- enable KindSignatures. The likelihood is already quite small, however. -- This function is only used for the benefit of {make,declare}Wrapped, and -- one needs to enable TypeFamilies in order for the generated code to -- typecheck. Since TypeFamilies implies KindSignatures, dropping kind -- signatures is probably not required, but better to be safe then sorry. dropSigsIfNonDataFam di $ applySubstitution (Map.fromList (zip (map tvName vars) args)) instTypes overHead :: (a -> a) -> [a] -> [a] overHead _ [] = [] overHead f (x:xs) = f x : xs -- | Field rules for fields in the form @ _prefix_fieldname @ underscoreFields :: LensRules underscoreFields = defaultFieldRules & lensField .~ underscoreNamer -- | A 'FieldNamer' for 'underscoreFields'. underscoreNamer :: FieldNamer underscoreNamer _ _ field = maybeToList $ do _ <- prefix field' method <- niceLens cls <- classNaming return (MethodName (mkName cls) (mkName method)) where field' = nameBase field prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs) prefix _ = Nothing niceLens = prefix field' <&> \n -> drop (length n + 2) field' classNaming = niceLens <&> ("Has_" ++) -- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @ -- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. -- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created. -- -- __Note__: The @prefix@ must be the same as the typename (with the first -- letter lowercased). This is a change from lens versions before lens 4.5. -- If you want the old behaviour, use 'makeLensesWith' 'abbreviatedFields' camelCaseFields :: LensRules camelCaseFields = defaultFieldRules -- | A 'FieldNamer' for 'camelCaseFields'. camelCaseNamer :: FieldNamer camelCaseNamer tyName fields field = maybeToList $ do fieldPart <- List.stripPrefix expectedPrefix (nameBase field) method <- computeMethod fieldPart let cls = "Has" ++ fieldPart return (MethodName (mkName cls) (mkName method)) where expectedPrefix = optUnderscore ++ overHead toLower (nameBase tyName) optUnderscore = ['_' | any (List.isPrefixOf "_" . nameBase) fields ] computeMethod (x:xs) | isUpper x = Just (toLower x : xs) computeMethod _ = Nothing -- | Field rules for fields in the form @ _fieldname @ (the leading -- underscore is mandatory). -- -- __Note__: The primary difference to 'camelCaseFields' is that for -- @classUnderscoreNoPrefixFields@ the field names are not expected to -- be prefixed with the type name. This might be the desired behaviour -- when the @DuplicateRecordFields@ extension is enabled. classUnderscoreNoPrefixFields :: LensRules classUnderscoreNoPrefixFields = defaultFieldRules & lensField .~ classUnderscoreNoPrefixNamer -- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'. classUnderscoreNoPrefixNamer :: FieldNamer classUnderscoreNoPrefixNamer _ _ field = maybeToList $ do fieldUnprefixed <- List.stripPrefix "_" (nameBase field) let className = "Has" ++ overHead toUpper fieldUnprefixed methodName = fieldUnprefixed return (MethodName (mkName className) (mkName methodName)) -- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @ -- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. -- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created. -- -- Note that @prefix@ may be any string of characters that are not uppercase -- letters. (In particular, it may be arbitrary string of lowercase letters -- and numbers) This is the behavior that 'defaultFieldRules' had in lens -- 4.4 and earlier. abbreviatedFields :: LensRules abbreviatedFields = defaultFieldRules { _fieldToDef = abbreviatedNamer } -- | A 'FieldNamer' for 'abbreviatedFields'. abbreviatedNamer :: FieldNamer abbreviatedNamer _ fields field = maybeToList $ do fieldPart <- stripMaxLc (nameBase field) method <- computeMethod fieldPart let cls = "Has" ++ fieldPart return (MethodName (mkName cls) (mkName method)) where stripMaxLc f = do x <- List.stripPrefix optUnderscore f case break isUpper x of (p,s) | List.null p || List.null s -> Nothing | otherwise -> Just s optUnderscore = ['_' | any (List.isPrefixOf "_" . nameBase) fields ] computeMethod (x:xs) | isUpper x = Just (toLower x : xs) computeMethod _ = Nothing -- | Generate overloaded field accessors. -- -- /e.g/ -- -- @ -- data Foo a = Foo { _fooX :: 'Int', _fooY :: a } -- newtype Bar = Bar { _barX :: 'Char' } -- makeFields ''Foo -- makeFields ''Bar -- @ -- -- will create -- -- @ -- _fooXLens :: Lens' (Foo a) Int -- _fooYLens :: Lens (Foo a) (Foo b) a b -- class HasX s a | s -> a where -- x :: Lens' s a -- instance HasX (Foo a) Int where -- x = _fooXLens -- class HasY s a | s -> a where -- y :: Lens' s a -- instance HasY (Foo a) a where -- y = _fooYLens -- _barXLens :: Iso' Bar Char -- instance HasX Bar Char where -- x = _barXLens -- @ -- -- For details, see 'camelCaseFields'. -- -- @ -- makeFields = 'makeLensesWith' 'defaultFieldRules' -- @ makeFields :: Name -> DecsQ makeFields = makeFieldOptics camelCaseFields -- | Generate overloaded field accessors based on field names which -- are only prefixed with an underscore (e.g. '_name'), not -- additionally with the type name (e.g. '_fooName'). -- -- This might be the desired behaviour in case the -- @DuplicateRecordFields@ language extension is used in order to get -- rid of the necessity to prefix each field name with the type name. -- -- As an example: -- -- @ -- data Foo a = Foo { _x :: 'Int', _y :: a } -- newtype Bar = Bar { _x :: 'Char' } -- makeFieldsNoPrefix ''Foo -- makeFieldsNoPrefix ''Bar -- @ -- -- will create classes -- -- @ -- class HasX s a | s -> a where -- x :: Lens' s a -- class HasY s a | s -> a where -- y :: Lens' s a -- @ -- -- together with instances -- -- @ -- instance HasX (Foo a) Int -- instance HasY (Foo a) a where -- instance HasX Bar Char where -- @ -- -- For details, see 'classUnderscoreNoPrefixFields'. -- -- @ -- makeFieldsNoPrefix = 'makeLensesWith' 'classUnderscoreNoPrefixFields' -- @ makeFieldsNoPrefix :: Name -> DecsQ makeFieldsNoPrefix = makeFieldOptics classUnderscoreNoPrefixFields defaultFieldRules :: LensRules defaultFieldRules = LensRules { _simpleLenses = True , _generateSigs = True , _generateClasses = True -- classes will still be skipped if they already exist , _allowIsos = False -- generating Isos would hinder field class reuse , _allowUpdates = True , _lazyPatterns = False , _recordSyntax = False , _classyLenses = const Nothing , _fieldToDef = camelCaseNamer } -- Declaration quote stuff declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<) -- | Monad for emitting top-level declarations as a side effect. We also track -- the set of field class 'Name's that have been created and consult them to -- avoid creating duplicate classes. -- See #463 for more information. type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q) liftDeclare :: Q a -> Declare a liftDeclare = lift . lift runDeclare :: Declare [Dec] -> DecsQ runDeclare dec = do (out, endo) <- evalStateT (runWriterT dec) Set.empty return $ out ++ appEndo endo [] emit :: [Dec] -> Declare () emit decs = tell $ Endo (decs++) -- | Traverse each data, newtype, data instance or newtype instance -- declaration. traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec] traverseDataAndNewtype f = traverse go where go dec = case dec of DataD{} -> f dec NewtypeD{} -> f dec DataInstD{} -> f dec NewtypeInstD{} -> f dec -- Recurse into instance declarations because they main contain -- associated data family instances. InstanceD moverlap ctx inst body -> InstanceD moverlap ctx inst <$> traverse go body _ -> pure dec stripFields :: Dec -> Dec stripFields dec = case dec of DataD ctx tyName tyArgs kind cons derivings -> DataD ctx tyName tyArgs kind (map deRecord cons) derivings NewtypeD ctx tyName tyArgs kind con derivings -> NewtypeD ctx tyName tyArgs kind (deRecord con) derivings DataInstD ctx tyName tyArgs kind cons derivings -> DataInstD ctx tyName tyArgs kind (map deRecord cons) derivings NewtypeInstD ctx tyName tyArgs kind con derivings -> NewtypeInstD ctx tyName tyArgs kind (deRecord con) derivings _ -> dec deRecord :: Con -> Con deRecord con@NormalC{} = con deRecord con@InfixC{} = con deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields) deRecord con@GadtC{} = con deRecord (RecGadtC ns fields retTy) = GadtC ns (map dropFieldName fields) retTy dropFieldName :: VarBangType -> BangType dropFieldName (_, str, typ) = (str, typ) lens-5.2.3/src/Control/Lens/Traversal.hs0000644000000000000000000015653107346545000016275 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ConstraintKinds #-} #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal -- Copyright : (C) 2012-16 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 -- @ -- -- A 'Traversal' can be used as a 'Fold'. -- Any 'Traversal' 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 a 'Traversal', and here we provide combinators that generalize -- the usual 'Traversable' operations. ---------------------------------------------------------------------------- module Control.Lens.Traversal ( -- * Traversals Traversal, Traversal' , Traversal1, Traversal1' , IndexedTraversal, IndexedTraversal' , IndexedTraversal1, IndexedTraversal1' , ATraversal, ATraversal' , ATraversal1, ATraversal1' , AnIndexedTraversal, AnIndexedTraversal' , AnIndexedTraversal1, AnIndexedTraversal1' , Traversing, Traversing' , Traversing1, Traversing1' -- * Traversing and Lensing , traversal , traverseOf, forOf, sequenceAOf , mapMOf, forMOf, sequenceOf , transposeOf , mapAccumLOf, mapAccumROf , scanr1Of, scanl1Of , failover, ifailover -- * Monomorphic Traversals , cloneTraversal , cloneIndexPreservingTraversal , cloneIndexedTraversal , cloneTraversal1 , cloneIndexPreservingTraversal1 , cloneIndexedTraversal1 -- * Parts and Holes , partsOf, partsOf' , unsafePartsOf, unsafePartsOf' , holesOf, holes1Of , singular, unsafeSingular -- * Common Traversals , Traversable(traverse) , Traversable1(traverse1) , both, both1 , beside , taking , dropping , failing , deepOf -- * Indexed Traversals -- ** Common , ignored , TraverseMin(..) , TraverseMax(..) , traversed , traversed1 , traversed64 , elementOf , element , elementsOf , elements -- ** Combinators , ipartsOf , ipartsOf' , iunsafePartsOf , iunsafePartsOf' , itraverseOf , iforOf , imapMOf , iforMOf , imapAccumROf , imapAccumLOf -- * Reflection , traverseBy , traverseByOf , sequenceBy , sequenceByOf -- * Implementation Details , Bazaar(..), Bazaar' , Bazaar1(..), Bazaar1' , loci , iloci -- * Fusion , confusing ) where import Prelude () import Control.Applicative.Backwards import qualified Control.Category as C import Control.Comonad import Control.Lens.Fold import Control.Lens.Getter (Getting, IndexedGetting, getting) import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Fold import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Control.Lens.Lens import Control.Lens.Setter (ASetter, AnIndexedSetter, isets, sets) import Control.Lens.Type import Control.Monad.Trans.State.Lazy import Data.Bitraversable import Data.CallStack import Data.Functor.Apply import Data.Functor.Day.Curried import Data.Functor.Yoneda import Data.Int import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Map (Map) import Data.Monoid (Any (..)) import Data.Sequence (Seq, mapWithIndex) import Data.Vector as Vector (Vector, imap) import Data.Profunctor.Rep (Representable (..)) import Data.Reflection import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable import Data.Tuple (swap) import GHC.Magic (inline) -- $setup -- >>> :set -XNoOverloadedStrings -XFlexibleContexts -- >>> import Data.Char (toUpper) -- >>> import Control.Applicative -- >>> import Control.Lens -- >>> import Control.Lens.Internal.Context -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate,try,ErrorCall(..)) -- >>> import Data.Maybe (fromMaybe) -- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Debug.SimpleReflect.Vars -- >>> import Data.Void -- >>> import Data.List (sort) -- >>> import System.Timeout (timeout) -- >>> import qualified Data.List.NonEmpty as NonEmpty -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force -- >>> let firstAndThird :: Traversal (a, x, a) (b, x, b) a b; firstAndThird = traversal go where { go :: Applicative f => (a -> f b) -> (a, x, a) -> f (b, x, b); go focus (a, x, a') = liftA3 (,,) (focus a) (pure x) (focus a') } -- >>> let selectNested :: Traversal (x, [a]) (x, [b]) a b; selectNested = traversal go where { go :: Applicative f => (a -> f b) -> (x, [a]) -> f (x, [b]); go focus (x, as) = liftA2 (,) (pure x) (traverse focus as) } ------------------------------------------------------------------------------ -- 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 a 'Traversal1'. type ATraversal1 s t a b = LensLike (Bazaar1 (->) a b) s t a b -- | @ -- type 'ATraversal1'' = 'Simple' 'ATraversal1' -- @ type ATraversal1' s a = ATraversal1 s s a a -- | When you see this as an argument to a function, it expects an 'IndexedTraversal'. type AnIndexedTraversal i s t a b = Over (Indexed i) (Bazaar (Indexed i) a b) s t a b -- | When you see this as an argument to a function, it expects an 'IndexedTraversal1'. type AnIndexedTraversal1 i s t a b = Over (Indexed i) (Bazaar1 (Indexed i) a b) s t a b -- | @ -- type 'AnIndexedTraversal'' = 'Simple' ('AnIndexedTraversal' i) -- @ type AnIndexedTraversal' i s a = AnIndexedTraversal i s s a a -- | @ -- type 'AnIndexedTraversal1'' = 'Simple' ('AnIndexedTraversal1' i) -- @ type AnIndexedTraversal1' i s a = AnIndexedTraversal1 i s s a a -- | When you see this as an argument to a function, it expects -- -- * to be indexed if @p@ is an instance of 'Indexed' i, -- -- * to be unindexed if @p@ is @(->)@, -- -- * a 'Traversal' if @f@ is 'Applicative', -- -- * a 'Getter' if @f@ is only a 'Functor' and 'Data.Functor.Contravariant.Contravariant', -- -- * a 'Lens' if @f@ is only a 'Functor', -- -- * a 'Fold' if @f@ is 'Applicative' and 'Data.Functor.Contravariant.Contravariant'. type Traversing p f s t a b = Over p (BazaarT p f a b) s t a b type Traversing1 p f s t a b = Over p (BazaarT1 p f a b) s t a b -- | @ -- type 'Traversing'' f = 'Simple' ('Traversing' f) -- @ type Traversing' p f s a = Traversing p f s s a a type Traversing1' p f s a = Traversing1 p f s s a a -------------------------- -- Traversal Combinators -------------------------- -- | Build a 'Traversal' by providing a function which specifies the elements you wish to -- focus. -- -- The caller provides a function of type: -- -- @ -- Applicative f => (a -> f b) -> s -> f t -- @ -- -- Which is a higher order function which accepts a "focusing function" and applies -- it to all desired focuses within @s@, then constructs a @t@ using the Applicative -- instance of @f@. -- -- Only elements which are "focused" using the focusing function will be targeted by the -- resulting traversal. -- -- For example, we can explicitly write a traversal which targets the first and third elements -- of a tuple like this: -- -- @ -- firstAndThird :: Traversal (a, x, a) (b, x, b) a b -- firstAndThird = traversal go -- where -- go :: Applicative f => (a -> f b) -> (a, x, a) -> f (b, x, b) -- go focus (a, x, a') = liftA3 (,,) (focus a) (pure x) (focus a') -- @ -- -- >>> (1,"two",3) & firstAndThird *~ 10 -- (10,"two",30) -- -- >>> over firstAndThird length ("one",2,"three") -- (3,2,5) -- -- We can re-use existing 'Traversal's when writing new ones by passing our focusing function -- along to them. This example re-uses 'traverse' to focus all elements in a list which is -- embedded in a tuple. This traversal could also be written simply as @_2 . traverse@. -- -- @ -- selectNested :: Traversal (x, [a]) (x, [b]) a b -- selectNested = traversal go -- where -- go :: Applicative f => (a -> f b) -> (x, [a]) -> f (x, [b]) -- go focus (x, as) = liftA2 (,) (pure x) (traverse focus as) -- @ -- -- >>> selectNested .~ "hello" $ (1,[2,3,4,5]) -- (1,["hello","hello","hello","hello"]) -- -- >>> (1,[2,3,4,5]) & selectNested *~ 3 -- (1,[6,9,12,15]) -- -- Note that the 'traversal' function actually just returns the same function you pass to -- it. The function it accepts is in fact a valid traversal all on its own! The use of -- 'traversal' does nothing except verify that the function it is passed matches the signature -- of a valid traversal. One could remove the @traversal@ combinator from either of the last -- two examples and use the definition of @go@ directly with no change in behaviour. -- -- This function exists for consistency with the 'lens', 'prism' and 'iso' constructors -- as well as to serve as a touchpoint for beginners who wish to construct their own -- traversals but are uncertain how to do so. traversal :: ((a -> f b) -> s -> f t) -> LensLike f s t a b traversal = id {-# INLINE traversal #-} -- | 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' -- 'itraverseOf' 'itraversed' ≡ 'itraverse' -- @ -- -- -- 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' :: 'Apply' f => 'Traversal1' 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 :: LensLike f s t a b -> (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 :: LensLike f s t a b -> s -> (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 :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t mapMOf = coerce {-# 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 :: LensLike (WrappedMonad m) s t a b -> s -> (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 :: LensLike (Backwards (State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumROf = mapAccumLOf . backwards {-# INLINE mapAccumROf #-} -- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. -- -- @ -- '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 :: LensLike (State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumLOf l f acc0 s = swap (runState (l g s) acc0) where g a = state $ \acc -> swap (f acc a) -- 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 ------------------------------------------------------------------------------- -- | '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. -- -- >>> (a,b,c) & partsOf each .~ [x,y,z] -- (x,y,z) -- -- Any extras will be lost. If you do not supply enough, then the remainder will come from the original structure. -- -- >>> (a,b,c) & partsOf each .~ [w,x,y,z] -- (w,x,y) -- -- >>> (a,b,c) & partsOf each .~ [x,y] -- (x,y,c) -- -- >>> ('b', 'a', 'd', 'c') & partsOf each %~ sort -- ('a','b','c','d') -- -- 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 = conjoined (\f s -> let b = inline l sell s in outs b <$> f (wins b)) (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in outs b <$> indexed f (is :: [i]) as) {-# 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 = conjoined (\f s -> let b = inline l sell s in outs b <$> f (wins b)) (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in outs b <$> indexed f (is :: [i]) as) {-# 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 = conjoined (\f s -> let b = inline l sell s in unsafeOuts b <$> f (wins b)) (\f s -> let b = inline l sell s; (is,as) = unzip (pins b) in unsafeOuts b <$> indexed f (is :: [i]) as) {-# 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 = conjoined (\f s -> let b = inline l sell s in unsafeOuts b <$> f (wins b)) (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in unsafeOuts b <$> indexed f (is :: [i]) as) {-# INLINE iunsafePartsOf' #-} -- | 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'. -- -- The resulting 'Lens' or 'Getter' will be partial if the supplied 'Traversal' returns -- no results. -- -- >>> [1,2,3] ^. singular _head -- 1 -- -- >>> Left (ErrorCall "singular: empty traversal") <- try (evaluate ([] ^. singular _head)) :: IO (Either ErrorCall ()) -- -- >>> Left 4 ^. singular _Left -- 4 -- -- >>> [1..10] ^. singular (ix 7) -- 8 -- -- >>> [] & singular traverse .~ 0 -- [] -- -- @ -- 'singular' :: 'Traversal' s t a a -> 'Lens' s t a a -- 'singular' :: 'Fold' s a -> 'Getter' 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 :: (HasCallStack, Conjoined p, Functor f) => Traversing p f s t a a -> Over p f s t a a singular l = conjoined (\afb s -> let b = l sell s in case ins b of (w:ws) -> unsafeOuts b . (:ws) <$> afb w [] -> unsafeOuts b . return <$> afb (error "singular: empty traversal")) (\pafb s -> let b = l sell s in case pins b of (w:ws) -> unsafeOuts b . (:map extract ws) <$> cosieve pafb w [] -> unsafeOuts b . return <$> cosieve pafb (error "singular: empty traversal")) {-# 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'. -- -- The resulting 'Lens' or 'Getter' will be partial if the 'Traversal' targets nothing -- or more than one element. -- -- >>> Left (ErrorCall "unsafeSingular: empty traversal") <- try (evaluate ([] & unsafeSingular traverse .~ 0)) :: IO (Either ErrorCall [Integer]) -- -- @ -- 'unsafeSingular' :: 'Traversal' s t a b -> 'Lens' s t a b -- 'unsafeSingular' :: 'Fold' s a -> 'Getter' 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 :: (HasCallStack, Conjoined p, Functor f) => Traversing p f s t a b -> Over p f s t a b unsafeSingular l = conjoined (\afb s -> let b = inline l sell s in case ins b of [w] -> unsafeOuts b . return <$> afb w [] -> error "unsafeSingular: empty traversal" _ -> error "unsafeSingular: traversing multiple results") (\pafb s -> let b = inline l sell s in case pins b of [w] -> unsafeOuts b . return <$> cosieve pafb w [] -> error "unsafeSingular: empty traversal" _ -> error "unsafeSingular: traversing multiple results") {-# INLINE unsafeSingular #-} ------------------------------------------------------------------------------ -- Internal functions used by 'partsOf', etc. ------------------------------------------------------------------------------ ins :: Bizarre (->) w => w a b t -> [a] ins = toListOf (getting bazaar) {-# INLINE ins #-} wins :: (Bizarre p w, Corepresentable p, Comonad (Corep p)) => w a b t -> [a] wins = getConst #. bazaar (cotabulate $ \ra -> Const [extract ra]) {-# INLINE wins #-} 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, C.Category p) => (a -> b) -> p a b parr f = lmap f C.id {-# INLINE parr #-} outs :: (Bizarre p w, C.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 #-} ------------------------------------------------------------------------------- -- Holes ------------------------------------------------------------------------------- -- | 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 = 'toListOf' 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 f xs = flip appEndo [] . fst $ runHoles (runBazaar (f sell xs) (cotabulate holeInOne)) id {-# INLINE holesOf #-} holeInOne :: (Corepresentable p, Comonad (Corep p)) => Corep p a -> Holes t (Endo [Pretext p a a t]) a holeInOne x = Holes $ \xt -> ( Endo (fmap xt (cosieve sell x) :) , extract x) {-# INLINABLE holeInOne #-} -- | The non-empty version of 'holesOf'. -- This extract a non-empty list of immediate children according to a given -- 'Traversal1' as editable contexts. -- -- >>> let head1 f s = runPretext (NonEmpty.head $ holes1Of traversed1 s) f -- >>> ('a' :| "bc") ^. head1 -- 'a' -- -- >>> ('a' :| "bc") & head1 %~ toUpper -- 'A' :| "bc" -- -- @ -- 'holes1Of' :: 'Iso'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s) -- 'holes1Of' :: 'Lens'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s) -- 'holes1Of' :: 'Traversal1'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s) -- 'holes1Of' :: 'IndexedLens'' i s a -> s -> 'NonEmpty' ('Pretext'' ('Indexed' i) a s) -- 'holes1Of' :: 'IndexedTraversal1'' i s a -> s -> 'NonEmpty' ('Pretext'' ('Indexed' i) a s) -- @ holes1Of :: Conjoined p => Over p (Bazaar1 p a a) s t a a -> s -> NonEmpty (Pretext p a a t) holes1Of f xs = flip getNonEmptyDList [] . fst $ runHoles (runBazaar1 (f sell xs) (cotabulate holeInOne1)) id {-# INLINE holes1Of #-} holeInOne1 :: forall p a t. (Corepresentable p, C.Category p) => Corep p a -> Holes t (NonEmptyDList (Pretext p a a t)) a holeInOne1 x = Holes $ \xt -> ( NonEmptyDList (fmap xt (cosieve sell x) :|) , cosieve (C.id :: p a a) x) -- We are very careful to share as much structure as possible among -- the results (in the common case where the traversal allows for such). -- Note in particular the recursive knot in the implementation of <*> -- for Holes. This sharing magic was inspired by Noah "Rampion" Easterly's -- implementation of a related holes function: see -- https://stackoverflow.com/a/49001904/1477667. The Holes type is -- inspired by Roman Cheplyaka's answer to that same question. newtype Holes t m x = Holes { runHoles :: (x -> t) -> (m, x) } instance Functor (Holes t m) where fmap f xs = Holes $ \xt -> let (qf, qv) = runHoles xs (xt . f) in (qf, f qv) instance Semigroup m => Apply (Holes t m) where fs <.> xs = Holes $ \xt -> let (pf, pv) = runHoles fs (xt . ($ qv)) (qf, qv) = runHoles xs (xt . pv) in (pf <> qf, pv qv) instance Monoid m => Applicative (Holes t m) where pure x = Holes $ \_ -> (mempty, x) fs <*> xs = Holes $ \xt -> let (pf, pv) = runHoles fs (xt . ($ qv)) (qf, qv) = runHoles xs (xt . pv) in (pf `mappend` qf, pv qv) #if MIN_VERSION_base(4,10,0) liftA2 f xs ys = Holes $ \xt -> let (pf, pv) = runHoles xs (xt . flip f qv) (qf, qv) = runHoles ys (xt . f pv) in (pf `mappend` qf, f pv qv) #endif ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------ -- | Traverse both parts of a 'Bitraversable' container with matching types. -- -- Usually that type will be a pair. Use 'Control.Lens.Each.each' to traverse -- the elements of arbitrary homogeneous tuples. -- -- >>> (1,2) & both *~ 10 -- (10,20) -- -- >>> over both length ("hello","world") -- (5,5) -- -- >>> ("hello","world")^.both -- "helloworld" -- -- @ -- 'both' :: 'Traversal' (a, a) (b, b) a b -- 'both' :: 'Traversal' ('Either' a a) ('Either' b b) a b -- @ both :: Bitraversable r => Traversal (r a a) (r b b) a b both f = bitraverse f f {-# INLINE both #-} -- | Traverse both parts of a 'Bitraversable1' container with matching types. -- -- Usually that type will be a pair. -- -- @ -- 'both1' :: 'Traversal1' (a, a) (b, b) a b -- 'both1' :: 'Traversal1' ('Either' a a) ('Either' b b) a b -- @ both1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b both1 f = bitraverse1 f f {-# INLINE both1 #-} -- | Apply a different 'Traversal' or 'Fold' to each side of a 'Bitraversable' container. -- -- @ -- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (r s s') (r t t') a b -- 'beside' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s' t' a b -> 'IndexedTraversal' i (r s s') (r t t') a b -- 'beside' :: 'IndexPreservingTraversal' s t a b -> 'IndexPreservingTraversal' s' t' a b -> 'IndexPreservingTraversal' (r s s') (r t t') a b -- @ -- -- @ -- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Lens' s t a b -> 'Lens' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Fold' s a -> 'Fold' s' a -> 'Fold' (s,s') a -- 'beside' :: 'Getter' s a -> 'Getter' s' a -> 'Fold' (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' :: '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 -- @ -- -- >>> ("hello",["world","!!!"])^..beside id traverse -- ["hello","world","!!!"] beside :: (Representable q, Applicative (Rep q), Applicative f, Bitraversable r) => Optical p q f s t a b -> Optical p q f s' t' a b -> Optical p q f (r s s') (r t t') a b beside l r f = tabulate $ getCompose #. bitraverse (Compose #. sieve (l f)) (Compose #. sieve (r f)) {-# 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' -> '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 :: (Conjoined p, Applicative f) => Int -> Traversing p f s t a a -> Over p f s t a a taking n l = conjoined (\ afb s -> let b = inline l sell s in outs b <$> traverse afb (take n $ ins b)) (\ pafb s -> let b = inline l sell s in outs b <$> traverse (cosieve pafb) (take n $ pins b)) {-# 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' -> '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 :: (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 cosieve 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.runTraversal' 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 (getting (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 -> cosieve 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 #-} -- | A 'Traversal1' is completely characterized by its behavior on a 'Bazaar1'. cloneTraversal1 :: ATraversal1 s t a b -> Traversal1 s t a b cloneTraversal1 l f = bazaar1 f . l sell {-# INLINE cloneTraversal1 #-} -- | Clone a 'Traversal1' yielding an 'IndexPreservingTraversal1' that passes through -- whatever index it is composed with. cloneIndexPreservingTraversal1 :: ATraversal1 s t a b -> IndexPreservingTraversal1 s t a b cloneIndexPreservingTraversal1 l pafb = cotabulate $ \ws -> runBazaar1 (l sell (extract ws)) $ \a -> cosieve pafb (a <$ ws) {-# INLINE cloneIndexPreservingTraversal1 #-} -- | Clone an 'IndexedTraversal1' yielding an 'IndexedTraversal1' with the same index. cloneIndexedTraversal1 :: AnIndexedTraversal1 i s t a b -> IndexedTraversal1 i s t a b cloneIndexedTraversal1 l f = bazaar1 (Indexed (indexed f)) . l sell {-# INLINE cloneIndexedTraversal1 #-} ------------------------------------------------------------------------------ -- Indexed Traversals ------------------------------------------------------------------------------ -- | 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' :: 'Apply' f => 'IndexedTraversal1' i s t a b -> (i -> a -> f b) -> s -> f t -- @ itraverseOf :: (Indexed i a (f b) -> s -> f t) -> (i -> a -> f b) -> s -> f t itraverseOf l = l .# Indexed {-# 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' :: 'Apply' f => 'IndexedTraversal1' i s t a b -> s -> (i -> a -> f b) -> f t -- @ iforOf :: (Indexed i a (f b) -> s -> f t) -> s -> (i -> a -> f b) -> f t iforOf = flip . itraverseOf {-# 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' :: 'Bind' m => 'IndexedTraversal1' i s t a b -> (i -> a -> m b) -> s -> m t -- @ imapMOf :: Over (Indexed i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t imapMOf = coerce {-# 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 = imapAccumLOf . backwards {-# 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 f acc0 s = swap (runState (l (Indexed g) s) acc0) where g i a = state $ \acc -> swap (f i acc a) {-# 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 [0] traversed #-} imapList :: (Int -> a -> b) -> [a] -> [b] imapList f = go 0 where go i (x:xs) = f i x : go (i+1) xs go _ [] = [] {-# INLINE imapList #-} {-# RULES "traversed -> mapped" traversed = sets fmap :: Functor f => ASetter (f a) (f b) a b; "traversed -> folded" traversed = folded :: Foldable f => Getting (Endo r) (f a) a; "traversed -> ifolded" traversed = folded :: Foldable f => IndexedGetting Int (Endo r) (f a) a; "traversed -> imapList" traversed = isets imapList :: AnIndexedSetter Int [a] [b] a b; "traversed -> imapSeq" traversed = isets mapWithIndex :: AnIndexedSetter Int (Seq a) (Seq b) a b; "traversed -> imapVector" traversed = isets Vector.imap :: AnIndexedSetter Int (Vector a) (Vector b) a b; #-} -- | Traverse any 'Traversable1' container. This is an 'IndexedTraversal1' that is indexed by ordinal position. traversed1 :: Traversable1 f => IndexedTraversal1 Int (f a) (f b) a b traversed1 = conjoined traverse1 (indexing traverse1) {-# INLINE traversed1 #-} -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed64 :: Traversable f => IndexedTraversal Int64 (f a) (f b) a b traversed64 = conjoined traverse (indexing64 traverse) {-# 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.IntMap where traverseMin f m = case IntMap.minViewWithKey m of Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const (Just v)) m 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.IntMap where traverseMax f m = case IntMap.maxViewWithKey m of Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const (Just v)) m 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/ '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 i = elementOf traverse i {-# 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 match a predicate. -- -- @ -- 'elements' ≡ 'elementsOf' 'traverse' -- @ elements :: Traversable t => (Int -> Bool) -> IndexedTraversal' Int (t a) a elements i = elementsOf traverse i {-# 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' :: Alternative m => Traversal s t a b -> (a -> b) -> s -> m t -- @ failover :: Alternative m => LensLike ((,) Any) s t a b -> (a -> b) -> s -> m t failover l afb s = case l ((,) (Any True) . afb) s of (Any True, t) -> pure t (Any False, _) -> empty {-# INLINE failover #-} -- | Try to map a function which uses the index over this 'IndexedTraversal', failing if the 'IndexedTraversal' has no targets. -- -- @ -- 'ifailover' :: Alternative m => IndexedTraversal i s t a b -> (i -> a -> b) -> s -> m t -- @ ifailover :: Alternative m => Over (Indexed i) ((,) Any) s t a b -> (i -> a -> b) -> s -> m t ifailover l iafb s = case l ((,) (Any True) `rmap` Indexed iafb) s of (Any True, t) -> pure t (Any False, _) -> empty {-# INLINE ifailover #-} -- | Try the first 'Traversal' (or 'Fold'), falling back on the second 'Traversal' (or 'Fold') if it returns no entries. -- -- This is only a valid 'Traversal' if the second 'Traversal' is disjoint from the result of the first or returns -- exactly the same results. These conditions are trivially met when given a 'Lens', 'Iso', 'Getter', 'Prism' or \"affine\" Traversal -- one that -- has 0 or 1 target. -- -- Mutatis mutandis for 'Fold'. -- -- >>> [0,1,2,3] ^? failing (ix 1) (ix 2) -- Just 1 -- -- >>> [0,1,2,3] ^? failing (ix 42) (ix 2) -- Just 2 -- -- @ -- 'failing' :: 'Traversal' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b -- 'failing' :: 'Prism' s t a b -> 'Prism' s t a b -> 'Traversal' s t a b -- 'failing' :: 'Fold' s a -> 'Fold' s a -> 'Fold' s a -- @ -- -- These cases are also supported, trivially, but are boring, because the left hand side always succeeds. -- -- @ -- 'failing' :: 'Lens' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b -- 'failing' :: 'Iso' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b -- 'failing' :: 'Equality' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b -- 'failing' :: 'Getter' s a -> 'Fold' s a -> 'Fold' s a -- @ -- -- If both of the inputs are indexed, the result is also indexed, so you can apply this to a pair of indexed -- traversals or indexed folds, obtaining an indexed traversal or indexed fold. -- -- @ -- 'failing' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -- 'failing' :: 'IndexedFold' i s a -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- @ -- -- These cases are also supported, trivially, but are boring, because the left hand side always succeeds. -- -- @ -- 'failing' :: 'IndexedLens' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -- 'failing' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- @ failing :: (Conjoined p, Applicative f) => Traversing p f s t a b -> Over p f s t a b -> Over p f s t a b failing l r pafb s = case pins b of [] -> r pafb s _ -> bazaar pafb b where b = l sell s infixl 5 `failing` -- | Try the second traversal. If it returns no entries, try again with all entries from the first traversal, recursively. -- -- @ -- 'deepOf' :: 'Fold' s s -> 'Fold' s a -> 'Fold' s a -- 'deepOf' :: 'Traversal'' s s -> 'Traversal'' s a -> 'Traversal'' s a -- 'deepOf' :: 'Traversal' s t s t -> 'Traversal' s t a b -> 'Traversal' s t a b -- 'deepOf' :: 'Fold' s s -> 'IndexedFold' i s a -> 'IndexedFold' i s a -- 'deepOf' :: 'Traversal' s t s t -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -- @ deepOf :: (Conjoined p, Applicative f) => LensLike f s t s t -> Traversing p f s t a b -> Over p f s t a b deepOf r l = failing l (r . deepOf r l) -- | "Fuse" a 'Traversal' by reassociating all of the @('<*>')@ operations to the -- left and fusing all of the 'fmap' calls into one. This is particularly -- useful when constructing a 'Traversal' using operations from "GHC.Generics". -- -- Given a pair of 'Traversal's 'foo' and 'bar', -- -- @ -- 'confusing' (foo.bar) = foo.bar -- @ -- -- However, @foo@ and @bar@ are each going to use the 'Applicative' they are given. -- -- 'confusing' exploits the 'Yoneda' lemma to merge their separate uses of 'fmap' into a single 'fmap'. -- and it further exploits an interesting property of the right Kan lift (or 'Curried') to left associate -- all of the uses of @('<*>')@ to make it possible to fuse together more fmaps. -- -- This is particularly effective when the choice of functor 'f' is unknown at compile -- time or when the 'Traversal' @foo.bar@ in the above description is recursive or complex -- enough to prevent inlining. -- -- 'Control.Lens.Lens.fusing' is a version of this combinator suitable for fusing lenses. -- -- @ -- 'confusing' :: 'Traversal' s t a b -> 'Traversal' s t a b -- @ confusing :: Applicative f => LensLike (Curried (Yoneda f) (Yoneda f)) s t a b -> LensLike f s t a b confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f) where liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) (Yoneda f) a liftCurriedYoneda fa = Curried (`yap` fa) {-# INLINE liftCurriedYoneda #-} yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa) {-# INLINE yap #-} {-# INLINE confusing #-} -- | Traverse a container using a specified 'Applicative'. -- -- This is like 'traverseBy' where the 'Traversable' instance can be specified by any 'Traversal' -- -- @ -- 'traverseByOf' 'traverse' ≡ 'traverseBy' -- @ traverseByOf :: Traversal s t a b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (a -> f b) -> s -> f t traverseByOf l pur app f = reifyApplicative pur app (l (ReflectedApplicative #. f)) -- | Sequence a container using a specified 'Applicative'. -- -- This is like 'traverseBy' where the 'Traversable' instance can be specified by any 'Traversal' -- -- @ -- 'sequenceByOf' 'traverse' ≡ 'sequenceBy' -- @ sequenceByOf :: Traversal s t (f b) b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> s -> f t sequenceByOf l pur app = reifyApplicative pur app (l ReflectedApplicative) lens-5.2.3/src/Control/Lens/Tuple.hs0000644000000000000000000014523507346545000015422 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Tuple -- Copyright : (C) 2012-16 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(..) , Field10(..) , Field11(..) , Field12(..) , Field13(..) , Field14(..) , Field15(..) , Field16(..) , Field17(..) , Field18(..) , Field19(..) -- * Strict variations , _1', _2', _3', _4', _5', _6', _7', _8', _9' , _10', _11', _12', _13', _14', _15', _16' , _17', _18', _19' ) where import Prelude () import Control.Lens.Lens import Control.Lens.Internal.Prelude import Data.Functor.Product (Product (..)) import Data.Kind import Data.Strict (Pair (..)) import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..), U1 (..)) -- $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 :: Lens s t a b default _1 :: (Generic s, Generic t, GIxed N0 (Rep s) (Rep t) a b) => Lens s t a b _1 = ix proxyN0 {-# INLINE _1 #-} instance Field1 (Identity a) (Identity b) a b where _1 f (Identity a) = Identity <$> f a instance Field1 (Product f g a) (Product f' g a) (f a) (f' a) where _1 f (Pair a b) = flip Pair b <$> f a instance Field1 ((f :*: g) p) ((f' :*: g) p) (f p) (f' p) where _1 f (l :*: r) = (:*: r) <$> f l -- | @since 4.20 instance Field1 (Pair a b) (Pair a' b) a a' where _1 f (a :!: b) = (:!: b) <$> f a -- | @ -- '_1' k ~(a,b) = (\\a' -> (a',b)) 'Data.Functor.<$>' k a -- @ instance Field1 (a,b) (a',b) a a' where _1 k ~(a,b) = k a <&> \a' -> (a',b) {-# INLINE _1 #-} instance Field1 (a,b,c) (a',b,c) a a' where _1 k ~(a,b,c) = k a <&> \a' -> (a',b,c) {-# INLINE _1 #-} instance Field1 (a,b,c,d) (a',b,c,d) a a' where _1 k ~(a,b,c,d) = k a <&> \a' -> (a',b,c,d) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e) (a',b,c,d,e) a a' where _1 k ~(a,b,c,d,e) = k a <&> \a' -> (a',b,c,d,e) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f) (a',b,c,d,e,f) a a' where _1 k ~(a,b,c,d,e,f) = k a <&> \a' -> (a',b,c,d,e,f) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g) (a',b,c,d,e,f,g) a a' where _1 k ~(a,b,c,d,e,f,g) = k a <&> \a' -> (a',b,c,d,e,f,g) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h) (a',b,c,d,e,f,g,h) a a' where _1 k ~(a,b,c,d,e,f,g,h) = k a <&> \a' -> (a',b,c,d,e,f,g,h) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' where _1 k ~(a,b,c,d,e,f,g,h,i) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j) (a',b,c,d,e,f,g,h,i,j) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk) (a',b,c,d,e,f,g,h,i,j,kk) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l) (a',b,c,d,e,f,g,h,i,j,kk,l) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a',b,c,d,e,f,g,h,i,j,kk,l,m) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a',b,c,d,e,f,g,h,i,j,kk,l,m,n) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m,n) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) a a' where _1 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _2 :: (Generic s, Generic t, GIxed N1 (Rep s) (Rep t) a b) => Lens s t a b _2 = ix proxyN1 {-# INLINE _2 #-} instance Field2 (Product f g a) (Product f g' a) (g a) (g' a) where _2 f (Pair a b) = Pair a <$> f b instance Field2 ((f :*: g) p) ((f :*: g') p) (g p) (g' p) where _2 f (l :*: r) = (l :*:) <$> f r -- | @since 4.20 instance Field2 (Pair a b) (Pair a b') b b' where _2 f (a :!: b) = (a :!:) <$> f 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) = k b <&> \b' -> (a,b') {-# INLINE _2 #-} instance Field2 (a,b,c) (a,b',c) b b' where _2 k ~(a,b,c) = k b <&> \b' -> (a,b',c) {-# INLINE _2 #-} instance Field2 (a,b,c,d) (a,b',c,d) b b' where _2 k ~(a,b,c,d) = k b <&> \b' -> (a,b',c,d) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e) (a,b',c,d,e) b b' where _2 k ~(a,b,c,d,e) = k b <&> \b' -> (a,b',c,d,e) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f) (a,b',c,d,e,f) b b' where _2 k ~(a,b,c,d,e,f) = k b <&> \b' -> (a,b',c,d,e,f) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g) (a,b',c,d,e,f,g) b b' where _2 k ~(a,b,c,d,e,f,g) = k b <&> \b' -> (a,b',c,d,e,f,g) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h) (a,b',c,d,e,f,g,h) b b' where _2 k ~(a,b,c,d,e,f,g,h) = k b <&> \b' -> (a,b',c,d,e,f,g,h) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i) (a,b',c,d,e,f,g,h,i) b b' where _2 k ~(a,b,c,d,e,f,g,h,i) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j) (a,b',c,d,e,f,g,h,i,j) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk) (a,b',c,d,e,f,g,h,i,j,kk) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b',c,d,e,f,g,h,i,j,kk,l) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b',c,d,e,f,g,h,i,j,kk,l,m) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b',c,d,e,f,g,h,i,j,kk,l,m,n) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m,n) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) b b' where _2 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _3 :: (Generic s, Generic t, GIxed N2 (Rep s) (Rep t) a b) => Lens s t a b _3 = ix proxyN2 {-# INLINE _3 #-} instance Field3 (a,b,c) (a,b,c') c c' where _3 k ~(a,b,c) = k c <&> \c' -> (a,b,c') {-# INLINE _3 #-} instance Field3 (a,b,c,d) (a,b,c',d) c c' where _3 k ~(a,b,c,d) = k c <&> \c' -> (a,b,c',d) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e) (a,b,c',d,e) c c' where _3 k ~(a,b,c,d,e) = k c <&> \c' -> (a,b,c',d,e) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f) (a,b,c',d,e,f) c c' where _3 k ~(a,b,c,d,e,f) = k c <&> \c' -> (a,b,c',d,e,f) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g) (a,b,c',d,e,f,g) c c' where _3 k ~(a,b,c,d,e,f,g) = k c <&> \c' -> (a,b,c',d,e,f,g) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h) (a,b,c',d,e,f,g,h) c c' where _3 k ~(a,b,c,d,e,f,g,h) = k c <&> \c' -> (a,b,c',d,e,f,g,h) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i) (a,b,c',d,e,f,g,h,i) c c' where _3 k ~(a,b,c,d,e,f,g,h,i) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j) (a,b,c',d,e,f,g,h,i,j) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c',d,e,f,g,h,i,j,kk) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c',d,e,f,g,h,i,j,kk,l) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c',d,e,f,g,h,i,j,kk,l,m) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c',d,e,f,g,h,i,j,kk,l,m,n) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m,n) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p,q) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p,q) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) c c' where _3 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _4 :: (Generic s, Generic t, GIxed N3 (Rep s) (Rep t) a b) => Lens s t a b _4 = ix proxyN3 {-# INLINE _4 #-} instance Field4 (a,b,c,d) (a,b,c,d') d d' where _4 k ~(a,b,c,d) = k d <&> \d' -> (a,b,c,d') {-# INLINE _4 #-} instance Field4 (a,b,c,d,e) (a,b,c,d',e) d d' where _4 k ~(a,b,c,d,e) = k d <&> \d' -> (a,b,c,d',e) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f) (a,b,c,d',e,f) d d' where _4 k ~(a,b,c,d,e,f) = k d <&> \d' -> (a,b,c,d',e,f) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g) (a,b,c,d',e,f,g) d d' where _4 k ~(a,b,c,d,e,f,g) = k d <&> \d' -> (a,b,c,d',e,f,g) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h) (a,b,c,d',e,f,g,h) d d' where _4 k ~(a,b,c,d,e,f,g,h) = k d <&> \d' -> (a,b,c,d',e,f,g,h) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i) (a,b,c,d',e,f,g,h,i) d d' where _4 k ~(a,b,c,d,e,f,g,h,i) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d',e,f,g,h,i,j) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d',e,f,g,h,i,j,kk) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d',e,f,g,h,i,j,kk,l) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d',e,f,g,h,i,j,kk,l,m) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d',e,f,g,h,i,j,kk,l,m,n) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m,n) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p,q) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p,q) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p,q,r) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) d d' where _4 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _5 :: (Generic s, Generic t, GIxed N4 (Rep s) (Rep t) a b) => Lens s t a b _5 = ix proxyN4 {-# INLINE _5 #-} instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where _5 k ~(a,b,c,d,e) = k e <&> \e' -> (a,b,c,d,e') {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f) (a,b,c,d,e',f) e e' where _5 k ~(a,b,c,d,e,f) = k e <&> \e' -> (a,b,c,d,e',f) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g) (a,b,c,d,e',f,g) e e' where _5 k ~(a,b,c,d,e,f,g) = k e <&> \e' -> (a,b,c,d,e',f,g) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h) (a,b,c,d,e',f,g,h) e e' where _5 k ~(a,b,c,d,e,f,g,h) = k e <&> \e' -> (a,b,c,d,e',f,g,h) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e',f,g,h,i) e e' where _5 k ~(a,b,c,d,e,f,g,h,i) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e',f,g,h,i,j) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e',f,g,h,i,j,kk) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e',f,g,h,i,j,kk,l) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e',f,g,h,i,j,kk,l,m) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e',f,g,h,i,j,kk,l,m,n) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m,n) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p,q) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p,q) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p,q,r) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p,q,r,s) e e' where _5 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _6 :: (Generic s, Generic t, GIxed N5 (Rep s) (Rep t) a b) => Lens s t a b _6 = ix proxyN5 {-# INLINE _6 #-} 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) = k f <&> \f' -> (a,b,c,d,e,f') {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g) (a,b,c,d,e,f',g) f f' where _6 k ~(a,b,c,d,e,f,g) = k f <&> \f' -> (a,b,c,d,e,f',g) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f',g,h) f f' where _6 k ~(a,b,c,d,e,f,g,h) = k f <&> \f' -> (a,b,c,d,e,f',g,h) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f',g,h,i) f f' where _6 k ~(a,b,c,d,e,f,g,h,i) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f',g,h,i,j) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e,f',g,h,i,j,kk) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f',g,h,i,j,kk,l) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f',g,h,i,j,kk,l,m) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f',g,h,i,j,kk,l,m,n) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m,n) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p,q) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p,q) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p,q,r) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p,q,r,s) f f' where _6 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _7 :: (Generic s, Generic t, GIxed N6 (Rep s) (Rep t) a b) => Lens s t a b _7 = ix proxyN6 {-# INLINE _7 #-} 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) = k g <&> \g' -> (a,b,c,d,e,f,g') {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g',h) g g' where _7 k ~(a,b,c,d,e,f,g,h) = k g <&> \g' -> (a,b,c,d,e,f,g',h) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g',h,i) g g' where _7 k ~(a,b,c,d,e,f,g,h,i) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f,g',h,i,j) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e,f,g',h,i,j,kk) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f,g',h,i,j,kk,l) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g',h,i,j,kk,l,m) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g',h,i,j,kk,l,m,n) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m,n) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p,q) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p,q) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p,q,r) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p,q,r) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p,q,r,s) g g' where _7 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _8 :: (Generic s, Generic t, GIxed N7 (Rep s) (Rep t) a b) => Lens s t a b _8 = ix proxyN7 {-# INLINE _8 #-} 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) = k h <&> \h' -> (a,b,c,d,e,f,g,h') {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h',i) h h' where _8 k ~(a,b,c,d,e,f,g,h,i) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f,g,h',i,j) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e,f,g,h',i,j,kk) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f,g,h',i,j,kk,l) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g,h',i,j,kk,l,m) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h',i,j,kk,l,m,n) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m,n) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p,q) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p,q) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p,q,r) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p,q,r) {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p,q,r,s) h h' where _8 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i,j,kk,l,m,n,o,p,q,r,s) {-# 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 :: Lens s t a b default _9 :: (Generic s, Generic t, GIxed N8 (Rep s) (Rep t) a b) => Lens s t a b _9 = ix proxyN8 {-# INLINE _9 #-} 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) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i') {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f,g,h,i',j) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e,f,g,h,i',j,kk) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f,g,h,i',j,kk,l) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g,h,i',j,kk,l,m) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h,i',j,kk,l,m,n) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m,n) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p,q) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p,q) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p,q,r) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p,q,r) {-# INLINE _9 #-} instance Field9 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p,q,r,s) i i' where _9 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i',j,kk,l,m,n,o,p,q,r,s) {-# INLINE _9 #-} -- | Provides access to the 10th field of a tuple. class Field10 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 10th field of a tuple. _10 :: Lens s t a b default _10 :: (Generic s, Generic t, GIxed N9 (Rep s) (Rep t) a b) => Lens s t a b _10 = ix proxyN9 {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f,g,h,i,j') j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j') {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e,f,g,h,i,j',kk) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f,g,h,i,j',kk,l) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g,h,i,j',kk,l,m) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h,i,j',kk,l,m,n) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m,n) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p,q) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p,q) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p,q,r) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p,q,r) {-# INLINE _10 #-} instance Field10 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p,q,r,s) j j' where _10 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k j <&> \j' -> (a,b,c,d,e,f,g,h,i,j',kk,l,m,n,o,p,q,r,s) {-# INLINE _10 #-} -- | Provides access to the 11th field of a tuple. class Field11 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 11th field of a tuple. _11 :: Lens s t a b default _11 :: (Generic s, Generic t, GIxed N10 (Rep s) (Rep t) a b) => Lens s t a b _11 = ix proxyN10 {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk) (a,b,c,d,e,f,g,h,i,j,kk') kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk') {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f,g,h,i,j,kk',l) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g,h,i,j,kk',l,m) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h,i,j,kk',l,m,n) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m,n) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p,q) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p,q) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p,q,r) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p,q,r) {-# INLINE _11 #-} instance Field11 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p,q,r,s) kk kk' where _11 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k kk <&> \kk' -> (a,b,c,d,e,f,g,h,i,j,kk',l,m,n,o,p,q,r,s) {-# INLINE _11 #-} -- | Provides access to the 12th field of a tuple. class Field12 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 12th field of a tuple. _12 :: Lens s t a b default _12 :: (Generic s, Generic t, GIxed N11 (Rep s) (Rep t) a b) => Lens s t a b _12 = ix proxyN11 {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l) (a,b,c,d,e,f,g,h,i,j,kk,l') l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l') {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g,h,i,j,kk,l',m) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m) {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h,i,j,kk,l',m,n) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m,n) {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o) {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p) {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p,q) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p,q) {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p,q,r) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p,q,r) {-# INLINE _12 #-} instance Field12 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p,q,r,s) l l' where _12 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k l <&> \l' -> (a,b,c,d,e,f,g,h,i,j,kk,l',m,n,o,p,q,r,s) {-# INLINE _12 #-} -- | Provides access to the 13th field of a tuple. class Field13 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 13th field of a tuple. _13 :: Lens s t a b default _13 :: (Generic s, Generic t, GIxed N12 (Rep s) (Rep t) a b) => Lens s t a b _13 = ix proxyN12 {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m) (a,b,c,d,e,f,g,h,i,j,kk,l,m') m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m') {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h,i,j,kk,l,m',n) m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m',n) {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o) m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o) {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p) m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p) {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p,q) m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p,q) {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p,q,r) m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p,q,r) {-# INLINE _13 #-} instance Field13 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p,q,r,s) m m' where _13 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k m <&> \m' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m',n,o,p,q,r,s) {-# INLINE _13 #-} -- | Provides access to the 14th field of a tuple. class Field14 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 14th field of a tuple. _14 :: Lens s t a b default _14 :: (Generic s, Generic t, GIxed N13 (Rep s) (Rep t) a b) => Lens s t a b _14 = ix proxyN13 {-# INLINE _14 #-} instance Field14 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n') n n' where _14 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n) = k n <&> \n' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n') {-# INLINE _14 #-} instance Field14 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o) n n' where _14 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k n <&> \n' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o) {-# INLINE _14 #-} instance Field14 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p) n n' where _14 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k n <&> \n' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p) {-# INLINE _14 #-} instance Field14 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p,q) n n' where _14 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k n <&> \n' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p,q) {-# INLINE _14 #-} instance Field14 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p,q,r) n n' where _14 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k n <&> \n' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p,q,r) {-# INLINE _14 #-} instance Field14 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p,q,r,s) n n' where _14 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k n <&> \n' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n',o,p,q,r,s) {-# INLINE _14 #-} -- | Provides access to the 15th field of a tuple. class Field15 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 15th field of a tuple. _15 :: Lens s t a b default _15 :: (Generic s, Generic t, GIxed N14 (Rep s) (Rep t) a b) => Lens s t a b _15 = ix proxyN14 {-# INLINE _15 #-} instance Field15 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o') o o' where _15 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o) = k o <&> \o' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o') {-# INLINE _15 #-} instance Field15 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p) o o' where _15 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k o <&> \o' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p) {-# INLINE _15 #-} instance Field15 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p,q) o o' where _15 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k o <&> \o' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p,q) {-# INLINE _15 #-} instance Field15 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p,q,r) o o' where _15 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k o <&> \o' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p,q,r) {-# INLINE _15 #-} instance Field15 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p,q,r,s) o o' where _15 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k o <&> \o' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o',p,q,r,s) {-# INLINE _15 #-} -- | Provides access to the 16th field of a tuple. class Field16 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 16th field of a tuple. _16 :: Lens s t a b default _16 :: (Generic s, Generic t, GIxed N15 (Rep s) (Rep t) a b) => Lens s t a b _16 = ix proxyN15 {-# INLINE _16 #-} instance Field16 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p') p p' where _16 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p) = k p <&> \p' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p') {-# INLINE _16 #-} instance Field16 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p',q) p p' where _16 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k p <&> \p' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p',q) {-# INLINE _16 #-} instance Field16 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p',q,r) p p' where _16 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k p <&> \p' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p',q,r) {-# INLINE _16 #-} instance Field16 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p',q,r,s) p p' where _16 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k p <&> \p' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p',q,r,s) {-# INLINE _16 #-} -- | Provides access to the 17th field of a tuple. class Field17 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 17th field of a tuple. _17 :: Lens s t a b default _17 :: (Generic s, Generic t, GIxed N16 (Rep s) (Rep t) a b) => Lens s t a b _17 = ix proxyN16 {-# INLINE _17 #-} instance Field17 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q') q q' where _17 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q) = k q <&> \q' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q') {-# INLINE _17 #-} instance Field17 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q',r) q q' where _17 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k q <&> \q' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q',r) {-# INLINE _17 #-} instance Field17 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q',r,s) q q' where _17 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k q <&> \q' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q',r,s) {-# INLINE _17 #-} -- | Provides access to the 18th field of a tuple. class Field18 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 18th field of a tuple. _18 :: Lens s t a b default _18 :: (Generic s, Generic t, GIxed N17 (Rep s) (Rep t) a b) => Lens s t a b _18 = ix proxyN17 {-# INLINE _18 #-} instance Field18 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r') r r' where _18 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r) = k r <&> \r' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r') {-# INLINE _18 #-} instance Field18 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r',s) r r' where _18 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k r <&> \r' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r',s) {-# INLINE _18 #-} -- | Provides access to the 19th field of a tuple. class Field19 s t a b | s -> a, t -> b, s b -> t, t a -> s where -- | Access the 19th field of a tuple. _19 :: Lens s t a b default _19 :: (Generic s, Generic t, GIxed N18 (Rep s) (Rep t) a b) => Lens s t a b _19 = ix proxyN18 {-# INLINE _19 #-} instance Field19 (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s') s s' where _19 k ~(a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s) = k s <&> \s' -> (a,b,c,d,e,f,g,h,i,j,kk,l,m,n,o,p,q,r,s') {-# INLINE _19 #-} -- Strict versions of the _1 .. _19 operations -- | Strict version of '_1' _1' :: Field1 s t a b => Lens s t a b _1' = \f !x -> _1 f x {-# INLINE _1' #-} -- | Strict version of '_2' _2' :: Field2 s t a b => Lens s t a b _2' = \f !x -> _2 f x {-# INLINE _2' #-} -- | Strict version of '_3' _3' :: Field3 s t a b => Lens s t a b _3' = \f !x -> _3 f x {-# INLINE _3' #-} -- | Strict version of '_4' _4' :: Field4 s t a b => Lens s t a b _4' = \f !x -> _4 f x {-# INLINE _4' #-} -- | Strict version of '_5' _5' :: Field5 s t a b => Lens s t a b _5' = \f !x -> _5 f x {-# INLINE _5' #-} -- | Strict version of '_6' _6' :: Field6 s t a b => Lens s t a b _6' = \f !x -> _6 f x {-# INLINE _6' #-} -- | Strict version of '_7' _7' :: Field7 s t a b => Lens s t a b _7' = \f !x -> _7 f x {-# INLINE _7' #-} -- | Strict version of '_8' _8' :: Field8 s t a b => Lens s t a b _8' = \f !x -> _8 f x {-# INLINE _8' #-} -- | Strict version of '_9' _9' :: Field9 s t a b => Lens s t a b _9' = \f !x -> _9 f x {-# INLINE _9' #-} -- | Strict version of '_10' _10' :: Field10 s t a b => Lens s t a b _10' = \f !x -> _10 f x {-# INLINE _10' #-} -- | Strict version of '_11' _11' :: Field11 s t a b => Lens s t a b _11' = \f !x -> _11 f x {-# INLINE _11' #-} -- | Strict version of '_12' _12' :: Field12 s t a b => Lens s t a b _12' = \f !x -> _12 f x {-# INLINE _12' #-} -- | Strict version of '_13' _13' :: Field13 s t a b => Lens s t a b _13' = \f !x -> _13 f x {-# INLINE _13' #-} -- | Strict version of '_14' _14' :: Field14 s t a b => Lens s t a b _14' = \f !x -> _14 f x {-# INLINE _14' #-} -- | Strict version of '_15' _15' :: Field15 s t a b => Lens s t a b _15' = \f !x -> _15 f x {-# INLINE _15' #-} -- | Strict version of '_16' _16' :: Field16 s t a b => Lens s t a b _16' = \f !x -> _16 f x {-# INLINE _16' #-} -- | Strict version of '_17' _17' :: Field17 s t a b => Lens s t a b _17' = \f !x -> _17 f x {-# INLINE _17' #-} -- | Strict version of '_18' _18' :: Field18 s t a b => Lens s t a b _18' = \f !x -> _18 f x {-# INLINE _18' #-} -- | Strict version of '_19' _19' :: Field19 s t a b => Lens s t a b _19' = \f !x -> _19 f x {-# INLINE _19' #-} ix :: (Generic s, Generic t, GIxed n (Rep s) (Rep t) a b) => f n -> Lens s t a b ix n f = fmap to . gix n f . from {-# INLINE ix #-} type family GSize (f :: Type -> Type) type instance GSize U1 = Z type instance GSize (K1 i c) = S Z type instance GSize (M1 i c f) = GSize f type instance GSize (a :*: b) = Add (GSize a) (GSize b) class GIxed n s t a b | n s -> a, n t -> b, n s b -> t, n t a -> s where gix :: f n -> Lens (s x) (t x) a b instance GIxed N0 (K1 i a) (K1 i b) a b where gix _ = dimap unK1 (fmap K1) {-# INLINE gix #-} instance GIxed n s t a b => GIxed n (M1 i c s) (M1 i c t) a b where gix n = dimap unM1 (fmap M1) . gix n {-# INLINE gix #-} instance (p ~ GT (GSize s) n, p ~ GT (GSize t) n, GIxed' p n s s' t t' a b) => GIxed n (s :*: s') (t :*: t') a b where gix = gix' (Proxy :: Proxy p) {-# INLINE gix #-} -- $gixed-fundeps -- >>> :set -XDeriveGeneric -XFlexibleInstances -XMultiParamTypeClasses -- >>> import GHC.Generics (Generic) -- >>> data Product a b = a :* b deriving Generic -- >>> instance Field1 (Product a b) (Product a' b) a a' -- >>> instance Field2 (Product a b) (Product a b') b b' class (p ~ GT (GSize s) n, p ~ GT (GSize t) n) => GIxed' p n s s' t t' a b | p n s s' -> a , p n t t' -> b , p n s s' b -> t t' , p n t t' a -> s s' where gix' :: f p -> g n -> Lens ((s :*: s') x) ((t :*: t') x) a b instance (GT (GSize s) n ~ T, GT (GSize t) n ~ T, GIxed n s t a b) => GIxed' T n s s' t s' a b where gix' _ n f (s :*: s') = (:*: s') <$> gix n f s {-# INLINE gix' #-} instance (GT (GSize s) n ~ F, n' ~ Subtract (GSize s) n, GIxed n' s' t' a b) => GIxed' F n s s' s t' a b where gix' _ _ f (s :*: s') = (s :*:) <$> gix (Proxy :: Proxy n') f s' {-# INLINE gix' #-} data Z data S a data T data F type family Add x y type instance Add Z y = y type instance Add (S x) y = S (Add x y) type family Subtract x y type instance Subtract Z x = x type instance Subtract (S x) (S y) = Subtract x y type family GT x y type instance GT Z x = F type instance GT (S x) Z = T type instance GT (S x) (S y) = GT x y type N0 = Z type N1 = S N0 type N2 = S N1 type N3 = S N2 type N4 = S N3 type N5 = S N4 type N6 = S N5 type N7 = S N6 type N8 = S N7 type N9 = S N8 type N10 = S N9 type N11 = S N10 type N12 = S N11 type N13 = S N12 type N14 = S N13 type N15 = S N14 type N16 = S N15 type N17 = S N16 type N18 = S N17 proxyN0 :: Proxy N0 proxyN0 = Proxy {-# INLINE proxyN0 #-} proxyN1 :: Proxy N1 proxyN1 = Proxy {-# INLINE proxyN1 #-} proxyN2 :: Proxy N2 proxyN2 = Proxy {-# INLINE proxyN2 #-} proxyN3 :: Proxy N3 proxyN3 = Proxy {-# INLINE proxyN3 #-} proxyN4 :: Proxy N4 proxyN4 = Proxy {-# INLINE proxyN4 #-} proxyN5 :: Proxy N5 proxyN5 = Proxy {-# INLINE proxyN5 #-} proxyN6 :: Proxy N6 proxyN6 = Proxy {-# INLINE proxyN6 #-} proxyN7 :: Proxy N7 proxyN7 = Proxy {-# INLINE proxyN7 #-} proxyN8 :: Proxy N8 proxyN8 = Proxy {-# INLINE proxyN8 #-} proxyN9 :: Proxy N9 proxyN9 = Proxy {-# INLINE proxyN9 #-} proxyN10 :: Proxy N10 proxyN10 = Proxy {-# INLINE proxyN10 #-} proxyN11 :: Proxy N11 proxyN11 = Proxy {-# INLINE proxyN11 #-} proxyN12 :: Proxy N12 proxyN12 = Proxy {-# INLINE proxyN12 #-} proxyN13 :: Proxy N13 proxyN13 = Proxy {-# INLINE proxyN13 #-} proxyN14 :: Proxy N14 proxyN14 = Proxy {-# INLINE proxyN14 #-} proxyN15 :: Proxy N15 proxyN15 = Proxy {-# INLINE proxyN15 #-} proxyN16 :: Proxy N16 proxyN16 = Proxy {-# INLINE proxyN16 #-} proxyN17 :: Proxy N17 proxyN17 = Proxy {-# INLINE proxyN17 #-} proxyN18 :: Proxy N18 proxyN18 = Proxy {-# INLINE proxyN18 #-} lens-5.2.3/src/Control/Lens/Type.hs0000644000000000000000000005532407346545000015251 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE PolyKinds #-} #else {-# LANGUAGE TypeInType #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Type -- Copyright : (C) 2012-16 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', As , Iso, Iso' , Prism , Prism' , Review , AReview -- * Lenses, Folds and Traversals , Lens, Lens' , Traversal, Traversal' , Traversal1, Traversal1' , Setter, Setter' , Getter, Fold , Fold1 -- * Indexed , IndexedLens, IndexedLens' , IndexedTraversal, IndexedTraversal' , IndexedTraversal1, IndexedTraversal1' , IndexedSetter, IndexedSetter' , IndexedGetter, IndexedFold , IndexedFold1 -- * Index-Preserving , IndexPreservingLens, IndexPreservingLens' , IndexPreservingTraversal, IndexPreservingTraversal' , IndexPreservingTraversal1, IndexPreservingTraversal1' , IndexPreservingSetter, IndexPreservingSetter' , IndexPreservingGetter, IndexPreservingFold , IndexPreservingFold1 -- * Common , Simple , LensLike, LensLike' , Over, Over' , IndexedLensLike, IndexedLensLike' , Optical, Optical' , Optic, Optic' ) where import Prelude () import Control.Lens.Internal.Prelude import Control.Lens.Internal.Setter import Control.Lens.Internal.Indexed import Data.Bifunctor import Data.Functor.Apply import Data.Kind -- $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 v s) ≡ v -- @ -- -- 2) Putting back what you got doesn't change anything: -- -- @ -- 'Control.Lens.Setter.set' l ('Control.Lens.Getter.view' l s) s ≡ s -- @ -- -- 3) Setting twice is the same as setting once: -- -- @ -- 'Control.Lens.Setter.set' l v' ('Control.Lens.Setter.set' l v s) ≡ 'Control.Lens.Setter.set' l v' s -- @ -- -- These laws are strong enough that the 4 type parameters of a 'Lens' cannot -- vary fully independently. For more on how they interact, read the \"Why is -- it a Lens Family?\" section of -- . -- -- There are some emergent properties of these laws: -- -- 1) @'Control.Lens.Setter.set' l s@ must be injective for every @s@ This is a consequence of law #1 -- -- 2) @'Control.Lens.Setter.set' l@ must be surjective, because of law #2, which indicates that it is possible to obtain any 'v' from some 's' such that @'Control.Lens.Setter.set' s v = s@ -- -- 3) Given just the first two laws you can prove a weaker form of law #3 where the values @v@ that you are setting match: -- -- @ -- 'Control.Lens.Setter.set' l v ('Control.Lens.Setter.set' l v s) ≡ 'Control.Lens.Setter.set' l v s -- @ -- -- Every 'Lens' can be used directly as a 'Control.Lens.Setter.Setter' or 'Traversal'. -- -- You can also use a 'Lens' for 'Control.Lens.Getter.Getting' as if it were a -- 'Fold' or 'Getter'. -- -- 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 -- | A 'Traversal' which targets at least one element. -- -- Note that since 'Apply' is not a superclass of 'Applicative', a 'Traversal1' -- cannot always be used in place of a 'Traversal'. In such circumstances -- 'Control.Lens.Traversal.cloneTraversal' will convert a 'Traversal1' into a 'Traversal'. type Traversal1 s t a b = forall f. Apply f => (a -> f b) -> s -> f t type Traversal1' s a = Traversal1 s s a a -- | Every 'IndexedTraversal' is a valid 'Control.Lens.Traversal.Traversal' or -- 'Control.Lens.Fold.IndexedFold'. -- -- 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. -- -- In addition, the index @i@ should satisfy the requirement that it stays -- unchanged even when modifying the value @a@, otherwise traversals like -- 'indices' break the 'Traversal' laws. 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 type IndexedTraversal1 i s t a b = forall p f. (Indexable i p, Apply f) => p a (f b) -> s -> f t type IndexedTraversal1' i s a = IndexedTraversal1 i s s a a -- | An 'IndexPreservingTraversal' 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 type IndexPreservingTraversal1 s t a b = forall p f. (Conjoined p, Apply f) => p a (f b) -> p s (f t) type IndexPreservingTraversal1' s a = IndexPreservingTraversal1 s s a a ------------------------------------------------------------------------------ -- Setters ------------------------------------------------------------------------------ -- | 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'' = 'Simple' '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'. -- -- Since every 'Iso' is both a valid 'Lens' and a valid 'Prism', the laws for those types -- imply the following laws for an 'Iso' 'f': -- -- @ -- f '.' 'Control.Lens.Iso.from' f ≡ 'id' -- 'Control.Lens.Iso.from' f '.' f ≡ '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 ------------------------------------------------------------------------------ -- Review Internals ------------------------------------------------------------------------------ -- | 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 t b = forall p f. (Choice p, Bifunctor p, Settable f) => Optic' p f t 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 t b = Optic' Tagged Identity t b ------------------------------------------------------------------------------ -- Prism Internals ------------------------------------------------------------------------------ -- | A 'Prism' @l@ is a 'Traversal' that can also be turned -- around with 'Control.Lens.Review.re' to obtain a 'Getter' in the -- opposite direction. -- -- There are three laws that a 'Prism' should satisfy: -- -- First, if I 'Control.Lens.Review.re' or 'Control.Lens.Review.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.Review.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 by @l@ and @a@: -- -- @ -- 'Control.Lens.Fold.preview' l s ≡ 'Just' a ⟹ 'Control.Lens.Review.review' l a ≡ s -- @ -- -- Third, if you get non-match @t@, you can convert it result back to @s@: -- -- @ -- 'Control.Lens.Combinators.matching' l s ≡ 'Left' t ⟹ 'Control.Lens.Combinators.matching' l t ≡ 'Left' s -- @ -- -- The first 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 an '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 :: k1) (t :: k2) (a :: k1) (b :: k2) = forall k3 (p :: k1 -> k3 -> Type) (f :: k2 -> k3) . p a (f b) -> p s (f t) -- | A 'Simple' 'Equality'. type Equality' s a = Equality s s a a -- | Composable `asTypeOf`. Useful for constraining excess -- polymorphism, @foo . (id :: As Int) . bar@. type As a = Equality' a a ------------------------------------------------------------------------------- -- Getters ------------------------------------------------------------------------------- -- | 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 @(s -> a)@. -- -- 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) -- | A relevant Fold (aka 'Fold1') has one or more targets. type Fold1 s a = forall f. (Contravariant f, Apply f) => (a -> f a) -> s -> f s type IndexedFold1 i s a = forall p f. (Indexable i p, Contravariant f, Apply f) => p a (f a) -> s -> f s type IndexPreservingFold1 s a = forall p f. (Conjoined p, Contravariant f, Apply f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- -- 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 ------------------------------------------------------------------------------- -- Optics ------------------------------------------------------------------------------- -- | A valid 'Optic' @l@ should satisfy the laws: -- -- @ -- l 'pure' ≡ 'pure' -- l ('Procompose' f g) = 'Procompose' (l f) (l g) -- @ -- -- This gives rise to the laws for 'Equality', 'Iso', 'Prism', 'Lens', -- 'Traversal', 'Traversal1', 'Setter', 'Fold', 'Fold1', and 'Getter' as well -- along with their index-preserving variants. -- -- @ -- type 'LensLike' f s t a b = 'Optic' (->) f s t a b -- @ type Optic p f s t a b = p a (f b) -> p s (f t) -- | @ -- type 'Optic'' p f s a = 'Simple' ('Optic' p f) s a -- @ type Optic' p f s a = Optic p f s s a a -- | @ -- type 'LensLike' f s t a b = 'Optical' (->) (->) f s t a b -- @ -- -- @ -- type 'Over' p f s t a b = 'Optical' p (->) f s t a b -- @ -- -- @ -- type 'Optic' p f s t a b = 'Optical' p p f s t a b -- @ type Optical p q f s t a b = p a (f b) -> q s (f t) -- | @ -- type 'Optical'' p q f s a = 'Simple' ('Optical' p q f) s a -- @ type Optical' p q f s a = Optical p q f s s a a -- | Many combinators that accept a 'Lens' can also accept a -- 'Traversal' in limited situations. -- -- 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-5.2.3/src/Control/Lens/Unsound.hs0000644000000000000000000000560107346545000015754 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Unsound -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- -- One commonly asked question is: can we combine two lenses, -- @'Lens'' a b@ and @'Lens'' a c@ into @'Lens'' a (b, c)@. -- This is fair thing to ask, but such operation is unsound in general. -- See `lensProduct`. -- ------------------------------------------------------------------------------- module Control.Lens.Unsound ( lensProduct , prismSum , adjoin ) where import Control.Lens import Control.Lens.Internal.Prelude import Prelude () -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | A lens product. There is no law-abiding way to do this in general. -- Result is only a valid t'Lens' if the input lenses project disjoint parts of -- the structure @s@. Otherwise "you get what you put in" law -- -- @ -- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l v s) ≡ v -- @ -- -- is violated by -- -- >>> let badLens :: Lens' (Int, Char) (Int, Int); badLens = lensProduct _1 _1 -- >>> view badLens (set badLens (1,2) (3,'x')) -- (2,2) -- -- but we should get @(1,2)@. -- -- Are you looking for 'Control.Lens.Lens.alongside'? -- lensProduct :: ALens' s a -> ALens' s b -> Lens' s (a, b) lensProduct l1 l2 f s = f (s ^# l1, s ^# l2) <&> \(a, b) -> s & l1 #~ a & l2 #~ b -- | A dual of `lensProduct`: a prism sum. -- -- The law -- -- @ -- 'Control.Lens.Fold.preview' l ('Control.Lens.Review.review' l b) ≡ 'Just' b -- @ -- -- breaks with -- -- >>> let badPrism :: Prism' (Maybe Char) (Either Char Char); badPrism = prismSum _Just _Just -- >>> preview badPrism (review badPrism (Right 'x')) -- Just (Left 'x') -- -- We put in 'Right' value, but get back 'Left'. -- -- Are you looking for 'Control.Lens.Prism.without'? -- prismSum :: APrism s t a b -> APrism s t c d -> Prism s t (Either a c) (Either b d) prismSum k k' = withPrism k $ \bt seta -> withPrism k' $ \dt setb -> prism (either bt dt) $ \s -> f (Left <$> seta s) (Right <$> setb s) where f a@(Right _) _ = a f (Left _) b = b -- | A generalization of `mappend`ing folds: A union of disjoint traversals. -- -- Traversing the same entry twice is illegal. -- -- Are you looking for 'Control.Lens.Traversal.failing'? -- adjoin :: Traversal' s a -> Traversal' s a -> Traversal' s a adjoin t1 t2 = lensProduct (partsOf t1) (partsOf t2) . both . each lens-5.2.3/src/Control/Lens/Wrapped.hs0000644000000000000000000012630407346545000015727 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #if !(MIN_VERSION_base(4,16,0)) || !MIN_VERSION_transformers(0,6,0) {-# OPTIONS_GHC -Wno-warnings-deprecations #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Wrapped -- Copyright : (C) 2012-16 Edward Kmett, Michael Sloan -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2, MPTCs, fundeps -- -- The t'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 ≡ '_Unwrapping' 'Sum' 'Control.Lens.Setter.%~' f -- Control.Newtype.under 'Sum' f ≡ '_Wrapping' 'Sum' 'Control.Lens.Setter.%~' f -- Control.Newtype.overF 'Sum' f ≡ 'mapping' ('_Unwrapping' 'Sum') 'Control.Lens.Setter.%~' f -- Control.Newtype.underF 'Sum' f ≡ 'mapping' ('_Wrapping' 'Sum') 'Control.Lens.Setter.%~' f -- @ -- -- 'under' can also be used with '_Unwrapping' to provide the equivalent of -- @Control.Newtype.under@. Also, most use cases don't need full polymorphism, -- so only the single constructor '_Wrapping' functions would be needed. -- -- 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 ( -- * Wrapping and Unwrapping monomorphically Wrapped(..) , _Unwrapped' , _Wrapping', _Unwrapping' -- * Wrapping and unwrapping polymorphically , Rewrapped, Rewrapping , _Wrapped, _Unwrapped , _Wrapping, _Unwrapping -- * Operations , op , ala, alaf -- * Pattern Synonyms , pattern Wrapped , pattern Unwrapped -- * Generics , _GWrapped' ) where #include "HsBaseConfig.h" import qualified Control.Alternative.Free as Free import qualified Control.Applicative as Applicative import Control.Applicative hiding (WrappedArrow(..)) import Control.Applicative.Trans.Free import Control.Arrow import Control.Applicative.Backwards import Control.Comonad.Trans.Cofree import Control.Comonad.Trans.Coiter import Control.Comonad.Trans.Traced import Control.Exception import Control.Lens.Getter import Control.Lens.Internal.CTypes import Control.Lens.Iso import Control.Lens.Review import Control.Monad.Catch.Pure import Control.Monad.Trans.Cont import Control.Monad.Trans.Except import Control.Monad.Trans.Free import Control.Monad.Trans.Identity import Control.Monad.Trans.Iter 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 #if !MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif import Data.Bifunctor.Biff import Data.Bifunctor.Clown import Data.Bifunctor.Fix import Data.Bifunctor.Flip import Data.Bifunctor.Join import Data.Bifunctor.Joker import Data.Bifunctor.Tannen import Data.Bifunctor.Wrapped import Data.Foldable as Foldable import Data.Functor.Bind import Data.Functor.Compose import Data.Functor.Contravariant import qualified Data.Functor.Contravariant.Compose as Contravariant import Data.Functor.Constant import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable import qualified Data.IntSet as IntSet import Data.IntSet (IntSet) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.HashSet as HashSet import Data.HashSet (HashSet) import qualified Data.HashMap.Lazy as HashMap import Data.HashMap.Lazy (HashMap) import Data.Kind import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Monoid as Monoid import Data.Monoid import qualified Data.Profunctor as Profunctor import Data.Profunctor hiding (WrappedArrow(..)) import Data.Profunctor.Cayley import qualified Data.Semigroup as S import Data.Semigroupoid import qualified Data.Semigroupoid.Dual as Semigroupoid import Data.Semigroupoid.Static import qualified Data.Sequence as Seq import Data.Sequence (Seq) import qualified Data.Set as Set import Data.Set (Set) import Data.Tagged import qualified Data.Vector as Vector import qualified Data.Vector.Primitive as Prim import Data.Vector.Primitive (Prim) import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Storable as Storable import Foreign.C.Error import Foreign.C.Types import Foreign.Storable (Storable) import qualified GHC.Generics as Generic import GHC.Generics hiding (from, to) import System.Posix.Types import Data.Ord (Down(Down)) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Foldable (foldMap) -- >>> import Data.Monoid (Sum (..), Product (..), All (..), Any (..)) -- | t'Wrapped' provides isomorphisms to wrap and unwrap newtypes or -- data types with one constructor. class Wrapped s where type Unwrapped s :: Type type Unwrapped s = GUnwrapped (Rep s) -- | An isomorphism between @s@ and @a@. -- -- If your type has a 'Generic' instance, '_Wrapped'' will default to '_GWrapped'', -- and you can choose to not override it with your own definition. _Wrapped' :: Iso' s (Unwrapped s) default _Wrapped' :: (Generic s, D1 d (C1 c (S1 s' (Rec0 a))) ~ Rep s, Unwrapped s ~ GUnwrapped (Rep s)) => Iso' s (Unwrapped s) _Wrapped' = _GWrapped' {-# INLINE _Wrapped' #-} -- | Implement the '_Wrapped' operation for a type using its 'Generic' instance. _GWrapped' :: (Generic s, D1 d (C1 c (S1 s' (Rec0 a))) ~ Rep s, Unwrapped s ~ GUnwrapped (Rep s)) => Iso' s (Unwrapped s) _GWrapped' = iso Generic.from Generic.to . iso remitter reviewer where remitter (M1 (M1 (M1 (K1 x)))) = x reviewer x = M1 (M1 (M1 (K1 x))) {-# INLINE _GWrapped' #-} type family GUnwrapped (rep :: Type -> Type) :: Type type instance GUnwrapped (D1 d (C1 c (S1 s (Rec0 a)))) = a pattern Wrapped :: Rewrapped s s => Unwrapped s -> s pattern Wrapped a <- (view _Wrapped -> a) where Wrapped a = review _Wrapped a pattern Unwrapped :: Rewrapped t t => t -> Unwrapped t pattern Unwrapped a <- (view _Unwrapped -> a) where Unwrapped a = review _Unwrapped a -- This can be used to help inference between the wrappers class Wrapped s => Rewrapped (s :: Type) (t :: Type) class (Rewrapped s t, Rewrapped t s) => Rewrapping s t instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t _Unwrapped' :: Wrapped s => Iso' (Unwrapped s) s _Unwrapped' = from _Wrapped' {-# INLINE _Unwrapped' #-} -- | Work under a newtype wrapper. -- -- >>> Const "hello" & _Wrapped %~ Prelude.length & getConst -- 5 -- -- @ -- '_Wrapped' ≡ 'from' '_Unwrapped' -- '_Unwrapped' ≡ 'from' '_Wrapped' -- @ _Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t) _Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt {-# INLINE _Wrapped #-} _Unwrapped :: Rewrapping s t => Iso (Unwrapped t) (Unwrapped s) t s _Unwrapped = from _Wrapped {-# INLINE _Unwrapped #-} -- * base instance (t ~ All) => Rewrapped All t instance Wrapped All where type Unwrapped All = Bool _Wrapped' = iso getAll All {-# INLINE _Wrapped' #-} instance (t ~ Any) => Rewrapped Any t instance Wrapped Any where type Unwrapped Any = Bool _Wrapped' = iso getAny Any {-# INLINE _Wrapped' #-} instance (t ~ Sum b) => Rewrapped (Sum a) t instance Wrapped (Sum a) where type Unwrapped (Sum a) = a _Wrapped' = iso getSum Sum {-# INLINE _Wrapped' #-} instance (t ~ Product b) => Rewrapped (Product a) t instance Wrapped (Product a) where type Unwrapped (Product a) = a _Wrapped' = iso getProduct Product {-# INLINE _Wrapped' #-} instance (t ~ Kleisli m' a' b') => Rewrapped (Kleisli m a b) t instance Wrapped (Kleisli m a b) where type Unwrapped (Kleisli m a b) = a -> m b _Wrapped' = iso runKleisli Kleisli {-# INLINE _Wrapped' #-} instance (t ~ WrappedMonad m' a') => Rewrapped (WrappedMonad m a) t instance Wrapped (WrappedMonad m a) where type Unwrapped (WrappedMonad m a) = m a _Wrapped' = iso unwrapMonad WrapMonad {-# INLINE _Wrapped' #-} instance (t ~ Applicative.WrappedArrow a' b' c') => Rewrapped (Applicative.WrappedArrow a b c) t instance Wrapped (Applicative.WrappedArrow a b c) where type Unwrapped (Applicative.WrappedArrow a b c) = a b c _Wrapped' = iso Applicative.unwrapArrow Applicative.WrapArrow {-# INLINE _Wrapped' #-} instance (t ~ ZipList b) => Rewrapped (ZipList a) t instance Wrapped (ZipList a) where type Unwrapped (ZipList a) = [a] _Wrapped' = iso getZipList ZipList {-# INLINE _Wrapped' #-} instance (t ~ NonEmpty b) => Rewrapped (NonEmpty a) t instance Wrapped (NonEmpty a) where type Unwrapped (NonEmpty a) = (a, [a]) _Wrapped' = iso (\(a :| as) -> (a, as)) (\(a,as) -> a :| as) {-# INLINE _Wrapped' #-} instance (t ~ Const a' x') => Rewrapped (Const a x) t instance Wrapped (Const a x) where type Unwrapped (Const a x) = a _Wrapped' = iso getConst Const {-# INLINE _Wrapped' #-} instance (t ~ Dual b) => Rewrapped (Dual a) t instance Wrapped (Dual a) where type Unwrapped (Dual a) = a _Wrapped' = iso getDual Dual {-# INLINE _Wrapped' #-} instance (t ~ Endo b) => Rewrapped (Endo a) t instance Wrapped (Endo a) where type Unwrapped (Endo a) = a -> a _Wrapped' = iso appEndo Endo {-# INLINE _Wrapped' #-} instance (t ~ First b) => Rewrapped (First a) t instance Wrapped (First a) where type Unwrapped (First a) = Maybe a _Wrapped' = iso getFirst First {-# INLINE _Wrapped' #-} instance (t ~ Last b) => Rewrapped (Last a) t instance Wrapped (Last a) where type Unwrapped (Last a) = Maybe a _Wrapped' = iso getLast Last {-# INLINE _Wrapped' #-} instance (t ~ Monoid.Alt g b) => Rewrapped (Monoid.Alt f a) t instance Wrapped (Monoid.Alt f a) where type Unwrapped (Monoid.Alt f a) = f a _Wrapped' = iso Monoid.getAlt Monoid.Alt {-# INLINE _Wrapped' #-} #if MIN_VERSION_base(4,12,0) instance (t ~ Monoid.Ap g b) => Rewrapped (Monoid.Ap f a) t instance Wrapped (Monoid.Ap f a) where type Unwrapped (Monoid.Ap f a) = f a _Wrapped' = iso Monoid.getAp Monoid.Ap {-# INLINE _Wrapped' #-} #endif instance t ~ ArrowMonad m' a' => Rewrapped (ArrowMonad m a) t instance Wrapped (ArrowMonad m a) where type Unwrapped (ArrowMonad m a) = m () a _Wrapped' = iso getArrowMonad ArrowMonad {-# INLINE _Wrapped' #-} instance t ~ Down b => Rewrapped (Down a) t instance Wrapped (Down a) where type Unwrapped (Down a) = a _Wrapped' = iso (\(Down a) -> a) Down {-# INLINE _Wrapped' #-} instance Rewrapped Errno t instance Wrapped Errno where type Unwrapped Errno = CInt _Wrapped' = iso (\(Errno x) -> x) Errno {-# INLINE _Wrapped' #-} getArrowMonad :: ArrowMonad m a -> m () a getArrowMonad (ArrowMonad x) = x {-# INLINE getArrowMonad #-} -- * transformers instance (t ~ Backwards g b) => Rewrapped (Backwards f a) t instance Wrapped (Backwards f a) where type Unwrapped (Backwards f a) = f a _Wrapped' = iso forwards Backwards instance (t ~ Compose f' g' a') => Rewrapped (Compose f g a) t instance Wrapped (Compose f g a) where type Unwrapped (Compose f g a) = f (g a) _Wrapped' = iso getCompose Compose instance (t ~ Constant a' b') => Rewrapped (Constant a b) t instance Wrapped (Constant a b) where type Unwrapped (Constant a b) = a _Wrapped' = iso getConstant Constant instance (t ~ ContT r' m' a') => Rewrapped (ContT r m a) t instance Wrapped (ContT r m a) where type Unwrapped (ContT r m a) = (a -> m r) -> m r _Wrapped' = iso runContT ContT instance (t ~ ExceptT e' m' a') => Rewrapped (ExceptT e m a) t instance Wrapped (ExceptT e m a) where type Unwrapped (ExceptT e m a) = m (Either e a) _Wrapped' = iso runExceptT ExceptT {-# INLINE _Wrapped' #-} instance (t ~ Identity b) => Rewrapped (Identity a) t instance Wrapped (Identity a) where type Unwrapped (Identity a) = a _Wrapped' = iso runIdentity Identity {-# INLINE _Wrapped' #-} instance (t ~ IdentityT n b) => Rewrapped (IdentityT m a) t instance Wrapped (IdentityT m a) where type Unwrapped (IdentityT m a) = m a _Wrapped' = iso runIdentityT IdentityT {-# INLINE _Wrapped' #-} instance (t ~ MaybeT n b) => Rewrapped (MaybeT m a) t instance Wrapped (MaybeT m a) where type Unwrapped (MaybeT m a) = m (Maybe a) _Wrapped' = iso runMaybeT MaybeT {-# INLINE _Wrapped' #-} instance (t ~ ReaderT s n b) => Rewrapped (ReaderT r m a) t instance Wrapped (ReaderT r m a) where type Unwrapped (ReaderT r m a) = r -> m a _Wrapped' = iso runReaderT ReaderT {-# INLINE _Wrapped' #-} instance (t ~ Reverse g b) => Rewrapped (Reverse f a) t instance Wrapped (Reverse f a) where type Unwrapped (Reverse f a) = f a _Wrapped' = iso getReverse Reverse {-# INLINE _Wrapped' #-} instance (t ~ Lazy.RWST r' w' s' m' a') => Rewrapped (Lazy.RWST r w s m a) t instance Wrapped (Lazy.RWST r w s m a) where type Unwrapped (Lazy.RWST r w s m a) = r -> s -> m (a, s, w) _Wrapped' = iso Lazy.runRWST Lazy.RWST {-# INLINE _Wrapped' #-} instance (t ~ Strict.RWST r' w' s' m' a') => Rewrapped (Strict.RWST r w s m a) t instance Wrapped (Strict.RWST r w s m a) where type Unwrapped (Strict.RWST r w s m a) = r -> s -> m (a, s, w) _Wrapped' = iso Strict.runRWST Strict.RWST {-# INLINE _Wrapped' #-} instance (t ~ Lazy.StateT s' m' a') => Rewrapped (Lazy.StateT s m a) t instance Wrapped (Lazy.StateT s m a) where type Unwrapped (Lazy.StateT s m a) = s -> m (a, s) _Wrapped' = iso Lazy.runStateT Lazy.StateT {-# INLINE _Wrapped' #-} instance (t ~ Strict.StateT s' m' a') => Rewrapped (Strict.StateT s m a) t instance Wrapped (Strict.StateT s m a) where type Unwrapped (Strict.StateT s m a) = s -> m (a, s) _Wrapped' = iso Strict.runStateT Strict.StateT {-# INLINE _Wrapped' #-} instance (t ~ Lazy.WriterT w' m' a') => Rewrapped (Lazy.WriterT w m a) t instance Wrapped (Lazy.WriterT w m a) where type Unwrapped (Lazy.WriterT w m a) = m (a, w) _Wrapped' = iso Lazy.runWriterT Lazy.WriterT {-# INLINE _Wrapped' #-} instance (t ~ Strict.WriterT w' m' a') => Rewrapped (Strict.WriterT w m a) t instance Wrapped (Strict.WriterT w m a) where type Unwrapped (Strict.WriterT w m a) = m (a, w) _Wrapped' = iso Strict.runWriterT Strict.WriterT {-# INLINE _Wrapped' #-} #if !MIN_VERSION_transformers(0,6,0) instance (t ~ ErrorT e' m' a') => Rewrapped (ErrorT e m a) t instance Wrapped (ErrorT e m a) where type Unwrapped (ErrorT e m a) = m (Either e a) _Wrapped' = iso runErrorT ErrorT {-# INLINE _Wrapped' #-} instance (t ~ ListT n b) => Rewrapped (ListT m a) t instance Wrapped (ListT m a) where type Unwrapped (ListT m a) = m [a] _Wrapped' = iso runListT ListT {-# INLINE _Wrapped' #-} #endif -- * bifunctors instance (t ~ Biff p' f' g' a' b') => Rewrapped (Biff p f g a b) t instance Wrapped (Biff p f g a b) where type Unwrapped (Biff p f g a b) = p (f a) (g b) _Wrapped' = iso runBiff Biff {-# INLINE _Wrapped' #-} instance (t ~ Clown f' a' b') => Rewrapped (Clown f a b) t instance Wrapped (Clown f a b) where type Unwrapped (Clown f a b) = f a _Wrapped' = iso runClown Clown {-# INLINE _Wrapped' #-} instance (t ~ Fix p' a') => Rewrapped (Fix p a) t instance Wrapped (Fix p a) where type Unwrapped (Fix p a) = p (Fix p a) a _Wrapped' = iso out In {-# INLINE _Wrapped' #-} instance (t ~ Flip p' a' b') => Rewrapped (Flip p a b) t instance Wrapped (Flip p a b) where type Unwrapped (Flip p a b) = p b a _Wrapped' = iso runFlip Flip {-# INLINE _Wrapped' #-} instance (t ~ Join p' a') => Rewrapped (Join p a) t instance Wrapped (Join p a) where type Unwrapped (Join p a) = p a a _Wrapped' = iso runJoin Join {-# INLINE _Wrapped' #-} instance (t ~ Joker g' a' b') => Rewrapped (Joker g a b) t instance Wrapped (Joker g a b) where type Unwrapped (Joker g a b) = g b _Wrapped' = iso runJoker Joker {-# INLINE _Wrapped' #-} instance (t ~ Tannen f' p' a' b') => Rewrapped (Tannen f p a b) t instance Wrapped (Tannen f p a b) where type Unwrapped (Tannen f p a b) = f (p a b) _Wrapped' = iso runTannen Tannen {-# INLINE _Wrapped' #-} instance (t ~ WrappedBifunctor p' a' b') => Rewrapped (WrappedBifunctor p a b) t instance Wrapped (WrappedBifunctor p a b) where type Unwrapped (WrappedBifunctor p a b) = p a b _Wrapped' = iso unwrapBifunctor WrapBifunctor {-# INLINE _Wrapped' #-} -- * comonad instance (t ~ TracedT m' w' a') => Rewrapped (TracedT m w a) t instance Wrapped (TracedT m w a) where type Unwrapped (TracedT m w a) = w (m -> a) _Wrapped' = iso runTracedT TracedT {-# INLINE _Wrapped' #-} -- * exceptions instance (t ~ CatchT m' a') => Rewrapped (CatchT m a) t instance Wrapped (CatchT m a) where type Unwrapped (CatchT m a) = m (Either SomeException a) _Wrapped' = iso runCatchT CatchT {-# INLINE _Wrapped' #-} -- * free instance (t ~ Free.Alt f' a') => Rewrapped (Free.Alt f a) t instance Wrapped (Free.Alt f a) where type Unwrapped (Free.Alt f a) = [Free.AltF f a] _Wrapped' = iso Free.alternatives Free.Alt {-# INLINE _Wrapped' #-} instance (t ~ ApT f' g' a') => Rewrapped (ApT f g a) t instance Wrapped (ApT f g a) where type Unwrapped (ApT f g a) = g (ApF f g a) _Wrapped' = iso getApT ApT {-# INLINE _Wrapped' #-} instance (t ~ CofreeT f' w' a') => Rewrapped (CofreeT f w a) t instance Wrapped (CofreeT f w a) where type Unwrapped (CofreeT f w a) = w (CofreeF f a (CofreeT f w a)) _Wrapped' = iso runCofreeT CofreeT {-# INLINE _Wrapped' #-} instance (t ~ CoiterT w' a') => Rewrapped (CoiterT w a) t instance Wrapped (CoiterT w a) where type Unwrapped (CoiterT w a) = w (a, CoiterT w a) _Wrapped' = iso runCoiterT CoiterT {-# INLINE _Wrapped' #-} instance (t ~ FreeT f' m' a') => Rewrapped (FreeT f m a) t instance Wrapped (FreeT f m a) where type Unwrapped (FreeT f m a) = m (FreeF f a (FreeT f m a)) _Wrapped' = iso runFreeT FreeT {-# INLINE _Wrapped' #-} instance (t ~ IterT m' a') => Rewrapped (IterT m a) t instance Wrapped (IterT m a) where type Unwrapped (IterT m a) = m (Either a (IterT m a)) _Wrapped' = iso runIterT IterT {-# INLINE _Wrapped' #-} -- * unordered-containers -- | Use @'_Wrapping' 'HashMap.fromList'@. Unwrapping returns some permutation of the list. instance (t ~ HashMap k' a', Hashable k, Eq k) => Rewrapped (HashMap k a) t instance (Hashable k, Eq k) => Wrapped (HashMap k a) where type Unwrapped (HashMap k a) = [(k, a)] _Wrapped' = iso HashMap.toList HashMap.fromList {-# INLINE _Wrapped' #-} -- | Use @'_Wrapping' 'HashSet.fromList'@. Unwrapping returns some permutation of the list. instance (t ~ HashSet a', Hashable a, Eq a) => Rewrapped (HashSet a) t instance (Hashable a, Eq a) => Wrapped (HashSet a) where type Unwrapped (HashSet a) = [a] _Wrapped' = iso HashSet.toList HashSet.fromList {-# INLINE _Wrapped' #-} -- * containers -- | Use @'_Wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ IntMap a') => Rewrapped (IntMap a) t instance Wrapped (IntMap a) where type Unwrapped (IntMap a) = [(Int, a)] _Wrapped' = iso IntMap.toAscList IntMap.fromList {-# INLINE _Wrapped' #-} -- | Use @'_Wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ IntSet) => Rewrapped IntSet t instance Wrapped IntSet where type Unwrapped IntSet = [Int] _Wrapped' = iso IntSet.toAscList IntSet.fromList {-# INLINE _Wrapped' #-} -- | Use @'_Wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ Map k' a', Ord k) => Rewrapped (Map k a) t instance Ord k => Wrapped (Map k a) where type Unwrapped (Map k a) = [(k, a)] _Wrapped' = iso Map.toAscList Map.fromList {-# INLINE _Wrapped' #-} -- | Use @'_Wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ Set a', Ord a) => Rewrapped (Set a) t instance Ord a => Wrapped (Set a) where type Unwrapped (Set a) = [a] _Wrapped' = iso Set.toAscList Set.fromList {-# INLINE _Wrapped' #-} instance (t ~ Seq a') => Rewrapped (Seq a) t instance Wrapped (Seq a) where type Unwrapped (Seq a) = [a] _Wrapped' = iso Foldable.toList Seq.fromList {-# INLINE _Wrapped' #-} -- * profunctors instance (t ~ Star f' d' c') => Rewrapped (Star f d c) t instance Wrapped (Star f d c) where type Unwrapped (Star f d c) = d -> f c _Wrapped' = iso runStar Star {-# INLINE _Wrapped' #-} instance (t ~ Costar f' d' c') => Rewrapped (Costar f d c) t instance Wrapped (Costar f d c) where type Unwrapped (Costar f d c) = f d -> c _Wrapped' = iso runCostar Costar {-# INLINE _Wrapped' #-} instance (t ~ Profunctor.WrappedArrow p' a' b') => Rewrapped (Profunctor.WrappedArrow p a b) t instance Wrapped (Profunctor.WrappedArrow p a b) where type Unwrapped (Profunctor.WrappedArrow p a b) = p a b _Wrapped' = iso Profunctor.unwrapArrow Profunctor.WrapArrow {-# INLINE _Wrapped' #-} instance (t ~ Forget r' a' b') => Rewrapped (Forget r a b) t instance Wrapped (Forget r a b) where type Unwrapped (Forget r a b) = a -> r _Wrapped' = iso runForget Forget {-# INLINE _Wrapped' #-} instance (t ~ Cayley f' p' a' b') => Rewrapped (Cayley f p a b) t instance Wrapped (Cayley f p a b) where type Unwrapped (Cayley f p a b) = f (p a b) _Wrapped' = iso runCayley Cayley {-# INLINE _Wrapped' #-} -- * vector instance (t ~ Vector.Vector a') => Rewrapped (Vector.Vector a) t instance Wrapped (Vector.Vector a) where type Unwrapped (Vector.Vector a) = [a] _Wrapped' = iso Vector.toList Vector.fromList {-# INLINE _Wrapped' #-} instance (Prim a, t ~ Prim.Vector a') => Rewrapped (Prim.Vector a) t instance Prim a => Wrapped (Prim.Vector a) where type Unwrapped (Prim.Vector a) = [a] _Wrapped' = iso Prim.toList Prim.fromList {-# INLINE _Wrapped' #-} instance (Unbox a, t ~ Unboxed.Vector a') => Rewrapped (Unboxed.Vector a) t instance Unbox a => Wrapped (Unboxed.Vector a) where type Unwrapped (Unboxed.Vector a) = [a] _Wrapped' = iso Unboxed.toList Unboxed.fromList {-# INLINE _Wrapped' #-} instance (Storable a, t ~ Storable.Vector a') => Rewrapped (Storable.Vector a) t instance Storable a => Wrapped (Storable.Vector a) where type Unwrapped (Storable.Vector a) = [a] _Wrapped' = iso Storable.toList Storable.fromList {-# INLINE _Wrapped' #-} -- * semigroupoids instance (t ~ WrappedApplicative f' a') => Rewrapped (WrappedApplicative f a) t instance Wrapped (WrappedApplicative f a) where type Unwrapped (WrappedApplicative f a) = f a _Wrapped' = iso unwrapApplicative WrapApplicative {-# INLINE _Wrapped' #-} instance (t ~ MaybeApply f' a') => Rewrapped (MaybeApply f a) t instance Wrapped (MaybeApply f a) where type Unwrapped (MaybeApply f a) = Either (f a) a _Wrapped' = iso runMaybeApply MaybeApply {-# INLINE _Wrapped' #-} instance (t ~ WrappedCategory k' a' b') => Rewrapped (WrappedCategory k a b) t instance Wrapped (WrappedCategory k a b) where type Unwrapped (WrappedCategory k a b) = k a b _Wrapped' = iso unwrapCategory WrapCategory {-# INLINE _Wrapped' #-} instance (t ~ Semi m' a' b') => Rewrapped (Semi m a b) t instance Wrapped (Semi m a b) where type Unwrapped (Semi m a b) = m _Wrapped' = iso getSemi Semi {-# INLINE _Wrapped' #-} instance (t ~ Semigroupoid.Dual k' a' b') => Rewrapped (Semigroupoid.Dual k a b) t instance Wrapped (Semigroupoid.Dual k a b) where type Unwrapped (Semigroupoid.Dual k a b) = k b a _Wrapped' = iso Semigroupoid.getDual Semigroupoid.Dual {-# INLINE _Wrapped' #-} instance (t ~ Static f' a' b') => Rewrapped (Static f a b) t instance Wrapped (Static f a b) where type Unwrapped (Static f a b) = f (a -> b) _Wrapped' = iso runStatic Static {-# INLINE _Wrapped' #-} -- * semigroups instance (t ~ S.Min b) => Rewrapped (S.Min a) t instance Wrapped (S.Min a) where type Unwrapped (S.Min a) = a _Wrapped' = iso S.getMin S.Min {-# INLINE _Wrapped' #-} instance (t ~ S.Max b) => Rewrapped (S.Max a) t instance Wrapped (S.Max a) where type Unwrapped (S.Max a) = a _Wrapped' = iso S.getMax S.Max {-# INLINE _Wrapped' #-} instance (t ~ S.First b) => Rewrapped (S.First a) t instance Wrapped (S.First a) where type Unwrapped (S.First a) = a _Wrapped' = iso S.getFirst S.First {-# INLINE _Wrapped' #-} instance (t ~ S.Last b) => Rewrapped (S.Last a) t instance Wrapped (S.Last a) where type Unwrapped (S.Last a) = a _Wrapped' = iso S.getLast S.Last {-# INLINE _Wrapped' #-} instance (t ~ S.WrappedMonoid b) => Rewrapped (S.WrappedMonoid a) t instance Wrapped (S.WrappedMonoid a) where type Unwrapped (S.WrappedMonoid a) = a _Wrapped' = iso S.unwrapMonoid S.WrapMonoid {-# INLINE _Wrapped' #-} #if !(MIN_VERSION_base(4,16,0)) instance (t ~ S.Option b) => Rewrapped (S.Option a) t instance Wrapped (S.Option a) where type Unwrapped (S.Option a) = Maybe a _Wrapped' = iso S.getOption S.Option {-# INLINE _Wrapped' #-} #endif -- * contravariant instance (t ~ Predicate b) => Rewrapped (Predicate a) t instance Wrapped (Predicate a) where type Unwrapped (Predicate a) = a -> Bool _Wrapped' = iso getPredicate Predicate {-# INLINE _Wrapped' #-} instance (t ~ Comparison b) => Rewrapped (Comparison a) t instance Wrapped (Comparison a) where type Unwrapped (Comparison a) = a -> a -> Ordering _Wrapped' = iso getComparison Comparison {-# INLINE _Wrapped' #-} instance (t ~ Equivalence b) => Rewrapped (Equivalence a) t instance Wrapped (Equivalence a) where type Unwrapped (Equivalence a) = a -> a -> Bool _Wrapped' = iso getEquivalence Equivalence {-# INLINE _Wrapped' #-} instance (t ~ Op a' b') => Rewrapped (Op a b) t instance Wrapped (Op a b) where type Unwrapped (Op a b) = b -> a _Wrapped' = iso getOp Op {-# INLINE _Wrapped' #-} instance (t ~ Contravariant.Compose f' g' a') => Rewrapped (Contravariant.Compose f g a) t instance Wrapped (Contravariant.Compose f g a) where type Unwrapped (Contravariant.Compose f g a) = f (g a) _Wrapped' = iso Contravariant.getCompose Contravariant.Compose {-# INLINE _Wrapped' #-} instance (t ~ Contravariant.ComposeFC f' g' a') => Rewrapped (Contravariant.ComposeFC f g a) t instance Wrapped (Contravariant.ComposeFC f g a) where type Unwrapped (Contravariant.ComposeFC f g a) = f (g a) _Wrapped' = iso Contravariant.getComposeFC Contravariant.ComposeFC {-# INLINE _Wrapped' #-} instance (t ~ Contravariant.ComposeCF f' g' a') => Rewrapped (Contravariant.ComposeCF f g a) t instance Wrapped (Contravariant.ComposeCF f g a) where type Unwrapped (Contravariant.ComposeCF f g a) = f (g a) _Wrapped' = iso Contravariant.getComposeCF Contravariant.ComposeCF {-# INLINE _Wrapped' #-} -- * tagged instance (t ~ Tagged s' a') => Rewrapped (Tagged s a) t instance Wrapped (Tagged s a) where type Unwrapped (Tagged s a) = a _Wrapped' = iso unTagged Tagged {-# INLINE _Wrapped' #-} -- * Control.Exception instance (t ~ AssertionFailed) => Rewrapped AssertionFailed t instance Wrapped AssertionFailed where type Unwrapped AssertionFailed = String _Wrapped' = iso failedAssertion AssertionFailed {-# INLINE _Wrapped' #-} instance (t ~ NoMethodError) => Rewrapped NoMethodError t instance Wrapped NoMethodError where type Unwrapped NoMethodError = String _Wrapped' = iso getNoMethodError NoMethodError {-# INLINE _Wrapped' #-} instance (t ~ PatternMatchFail) => Rewrapped PatternMatchFail t instance Wrapped PatternMatchFail where type Unwrapped PatternMatchFail = String _Wrapped' = iso getPatternMatchFail PatternMatchFail {-# INLINE _Wrapped' #-} instance (t ~ RecConError) => Rewrapped RecConError t instance Wrapped RecConError where type Unwrapped RecConError = String _Wrapped' = iso getRecConError RecConError {-# INLINE _Wrapped' #-} instance (t ~ RecSelError) => Rewrapped RecSelError t instance Wrapped RecSelError where type Unwrapped RecSelError = String _Wrapped' = iso getRecSelError RecSelError {-# INLINE _Wrapped' #-} instance (t ~ RecUpdError) => Rewrapped RecUpdError t instance Wrapped RecUpdError where type Unwrapped RecUpdError = String _Wrapped' = iso getRecUpdError RecUpdError {-# INLINE _Wrapped' #-} instance (t ~ ErrorCall) => Rewrapped ErrorCall t instance Wrapped ErrorCall where type Unwrapped ErrorCall = String _Wrapped' = iso getErrorCall ErrorCall {-# INLINE _Wrapped' #-} instance (t ~ TypeError) => Rewrapped TypeError t instance Wrapped TypeError where type Unwrapped TypeError = String _Wrapped' = iso getTypeError TypeError {-# INLINE _Wrapped' #-} getTypeError :: TypeError -> String getTypeError (TypeError x) = x {-# INLINE getTypeError #-} #if MIN_VERSION_base(4,10,0) instance (t ~ CompactionFailed) => Rewrapped CompactionFailed t instance Wrapped CompactionFailed where type Unwrapped CompactionFailed = String _Wrapped' = iso getCompactionFailed CompactionFailed {-# INLINE _Wrapped' #-} getCompactionFailed :: CompactionFailed -> String getCompactionFailed (CompactionFailed x) = x {-# INLINE getCompactionFailed #-} #endif getErrorCall :: ErrorCall -> String getErrorCall (ErrorCallWithLocation 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 #-} -- * Foreign.C.Types instance Rewrapped CChar t instance Wrapped CChar where type Unwrapped CChar = HTYPE_CHAR _Wrapped' = iso (\(CChar x) -> x) CChar {-# INLINE _Wrapped' #-} instance Rewrapped CSChar t instance Wrapped CSChar where type Unwrapped CSChar = HTYPE_SIGNED_CHAR _Wrapped' = iso (\(CSChar x) -> x) CSChar {-# INLINE _Wrapped' #-} instance Rewrapped CUChar t instance Wrapped CUChar where type Unwrapped CUChar = HTYPE_UNSIGNED_CHAR _Wrapped' = iso (\(CUChar x) -> x) CUChar {-# INLINE _Wrapped' #-} instance Rewrapped CShort t instance Wrapped CShort where type Unwrapped CShort = HTYPE_SHORT _Wrapped' = iso (\(CShort x) -> x) CShort {-# INLINE _Wrapped' #-} instance Rewrapped CUShort t instance Wrapped CUShort where type Unwrapped CUShort = HTYPE_UNSIGNED_SHORT _Wrapped' = iso (\(CUShort x) -> x) CUShort {-# INLINE _Wrapped' #-} instance Rewrapped CInt t instance Wrapped CInt where type Unwrapped CInt = HTYPE_INT _Wrapped' = iso (\(CInt x) -> x) CInt {-# INLINE _Wrapped' #-} instance Rewrapped CUInt t instance Wrapped CUInt where type Unwrapped CUInt = HTYPE_UNSIGNED_INT _Wrapped' = iso (\(CUInt x) -> x) CUInt {-# INLINE _Wrapped' #-} instance Rewrapped CLong t instance Wrapped CLong where type Unwrapped CLong = HTYPE_LONG _Wrapped' = iso (\(CLong x) -> x) CLong {-# INLINE _Wrapped' #-} instance Rewrapped CULong t instance Wrapped CULong where type Unwrapped CULong = HTYPE_UNSIGNED_LONG _Wrapped' = iso (\(CULong x) -> x) CULong {-# INLINE _Wrapped' #-} instance Rewrapped CLLong t instance Wrapped CLLong where type Unwrapped CLLong = HTYPE_LONG_LONG _Wrapped' = iso (\(CLLong x) -> x) CLLong {-# INLINE _Wrapped' #-} instance Rewrapped CULLong t instance Wrapped CULLong where type Unwrapped CULLong = HTYPE_UNSIGNED_LONG_LONG _Wrapped' = iso (\(CULLong x) -> x) CULLong {-# INLINE _Wrapped' #-} instance Rewrapped CFloat t instance Wrapped CFloat where type Unwrapped CFloat = HTYPE_FLOAT _Wrapped' = iso (\(CFloat x) -> x) CFloat {-# INLINE _Wrapped' #-} instance Rewrapped CDouble t instance Wrapped CDouble where type Unwrapped CDouble = HTYPE_DOUBLE _Wrapped' = iso (\(CDouble x) -> x) CDouble {-# INLINE _Wrapped' #-} instance Rewrapped CPtrdiff t instance Wrapped CPtrdiff where type Unwrapped CPtrdiff = HTYPE_PTRDIFF_T _Wrapped' = iso (\(CPtrdiff x) -> x) CPtrdiff {-# INLINE _Wrapped' #-} instance Rewrapped CSize t instance Wrapped CSize where type Unwrapped CSize = HTYPE_SIZE_T _Wrapped' = iso (\(CSize x) -> x) CSize {-# INLINE _Wrapped' #-} instance Rewrapped CWchar t instance Wrapped CWchar where type Unwrapped CWchar = HTYPE_WCHAR_T _Wrapped' = iso (\(CWchar x) -> x) CWchar {-# INLINE _Wrapped' #-} instance Rewrapped CSigAtomic t instance Wrapped CSigAtomic where type Unwrapped CSigAtomic = #if defined(HTYPE_SIG_ATOMIC_T) HTYPE_SIG_ATOMIC_T #else Int32 #endif _Wrapped' = iso (\(CSigAtomic x) -> x) CSigAtomic {-# INLINE _Wrapped' #-} instance Rewrapped CClock t instance Wrapped CClock where type Unwrapped CClock = HTYPE_CLOCK_T _Wrapped' = iso (\(CClock x) -> x) CClock {-# INLINE _Wrapped' #-} instance Rewrapped CTime t instance Wrapped CTime where type Unwrapped CTime = HTYPE_TIME_T _Wrapped' = iso (\(CTime x) -> x) CTime {-# INLINE _Wrapped' #-} instance Rewrapped CUSeconds t instance Wrapped CUSeconds where type Unwrapped CUSeconds = HTYPE_USECONDS_T _Wrapped' = iso (\(CUSeconds x) -> x) CUSeconds {-# INLINE _Wrapped' #-} instance Rewrapped CSUSeconds t instance Wrapped CSUSeconds where type Unwrapped CSUSeconds = HTYPE_SUSECONDS_T _Wrapped' = iso (\(CSUSeconds x) -> x) CSUSeconds {-# INLINE _Wrapped' #-} instance Rewrapped CIntPtr t instance Wrapped CIntPtr where type Unwrapped CIntPtr = HTYPE_INTPTR_T _Wrapped' = iso (\(CIntPtr x) -> x) CIntPtr {-# INLINE _Wrapped' #-} instance Rewrapped CUIntPtr t instance Wrapped CUIntPtr where type Unwrapped CUIntPtr = HTYPE_UINTPTR_T _Wrapped' = iso (\(CUIntPtr x) -> x) CUIntPtr {-# INLINE _Wrapped' #-} instance Rewrapped CIntMax t instance Wrapped CIntMax where type Unwrapped CIntMax = HTYPE_INTMAX_T _Wrapped' = iso (\(CIntMax x) -> x) CIntMax {-# INLINE _Wrapped' #-} instance Rewrapped CUIntMax t instance Wrapped CUIntMax where type Unwrapped CUIntMax = HTYPE_UINTMAX_T _Wrapped' = iso (\(CUIntMax x) -> x) CUIntMax {-# INLINE _Wrapped' #-} -- * GHC.Generics instance (t ~ Par1 p') => Rewrapped (Par1 p) t instance Wrapped (Par1 p) where type Unwrapped (Par1 p) = p _Wrapped' = iso unPar1 Par1 {-# INLINE _Wrapped' #-} instance (t ~ Rec1 f' p') => Rewrapped (Rec1 f p) t instance Wrapped (Rec1 f p) where type Unwrapped (Rec1 f p) = f p _Wrapped' = iso unRec1 Rec1 {-# INLINE _Wrapped' #-} instance (t ~ K1 i' c' p') => Rewrapped (K1 i c p) t instance Wrapped (K1 i c p) where type Unwrapped (K1 i c p) = c _Wrapped' = iso unK1 K1 {-# INLINE _Wrapped' #-} instance (t ~ M1 i' c' f' p') => Rewrapped (M1 i c f p) t instance Wrapped (M1 i c f p) where type Unwrapped (M1 i c f p) = f p _Wrapped' = iso unM1 M1 {-# INLINE _Wrapped' #-} instance (t ~ (f' :.: g') p') => Rewrapped ((f :.: g) p) t instance Wrapped ((f :.: g) p) where type Unwrapped ((f :.: g) p) = f (g p) _Wrapped' = iso unComp1 Comp1 {-# INLINE _Wrapped' #-} -- * System.Posix.Types #if defined(HTYPE_DEV_T) instance Rewrapped CDev t instance Wrapped CDev where type Unwrapped CDev = HTYPE_DEV_T _Wrapped' = iso (\(CDev x) -> x) CDev {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_INO_T) instance Rewrapped CIno t instance Wrapped CIno where type Unwrapped CIno = HTYPE_INO_T _Wrapped' = iso (\(CIno x) -> x) CIno {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_MODE_T) instance Rewrapped CMode t instance Wrapped CMode where type Unwrapped CMode = HTYPE_MODE_T _Wrapped' = iso (\(CMode x) -> x) CMode {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_OFF_T) instance Rewrapped COff t instance Wrapped COff where type Unwrapped COff = HTYPE_OFF_T _Wrapped' = iso (\(COff x) -> x) COff {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_PID_T) instance Rewrapped CPid t instance Wrapped CPid where type Unwrapped CPid = HTYPE_PID_T _Wrapped' = iso (\(CPid x) -> x) CPid {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_SSIZE_T) instance Rewrapped CSsize t instance Wrapped CSsize where type Unwrapped CSsize = HTYPE_SSIZE_T _Wrapped' = iso (\(CSsize x) -> x) CSsize {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_GID_T) instance Rewrapped CGid t instance Wrapped CGid where type Unwrapped CGid = HTYPE_GID_T _Wrapped' = iso (\(CGid x) -> x) CGid {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_NLINK_T) instance Rewrapped CNlink t instance Wrapped CNlink where type Unwrapped CNlink = HTYPE_NLINK_T _Wrapped' = iso (\(CNlink x) -> x) CNlink {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_UID_T) instance Rewrapped CUid t instance Wrapped CUid where type Unwrapped CUid = HTYPE_UID_T _Wrapped' = iso (\(CUid x) -> x) CUid {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_CC_T) instance Rewrapped CCc t instance Wrapped CCc where type Unwrapped CCc = HTYPE_CC_T _Wrapped' = iso (\(CCc x) -> x) CCc {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_SPEED_T) instance Rewrapped CSpeed t instance Wrapped CSpeed where type Unwrapped CSpeed = HTYPE_SPEED_T _Wrapped' = iso (\(CSpeed x) -> x) CSpeed {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_TCFLAG_T) instance Rewrapped CTcflag t instance Wrapped CTcflag where type Unwrapped CTcflag = HTYPE_TCFLAG_T _Wrapped' = iso (\(CTcflag x) -> x) CTcflag {-# INLINE _Wrapped' #-} #endif #if defined(HTYPE_RLIM_T) instance Rewrapped CRLim t instance Wrapped CRLim where type Unwrapped CRLim = HTYPE_RLIM_T _Wrapped' = iso (\(CRLim x) -> x) CRLim {-# INLINE _Wrapped' #-} #endif instance Rewrapped Fd t instance Wrapped Fd where type Unwrapped Fd = CInt _Wrapped' = iso (\(Fd x) -> x) Fd {-# INLINE _Wrapped' #-} #if MIN_VERSION_base(4,10,0) instance Rewrapped CBool t instance Wrapped CBool where type Unwrapped CBool = HTYPE_BOOL _Wrapped' = iso (\(CBool x) -> x) CBool {-# INLINE _Wrapped' #-} # if defined(HTYPE_BLKSIZE_T) instance Rewrapped CBlkSize t instance Wrapped CBlkSize where type Unwrapped CBlkSize = HTYPE_BLKSIZE_T _Wrapped' = iso (\(CBlkSize x) -> x) CBlkSize {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_BLKCNT_T) instance Rewrapped CBlkCnt t instance Wrapped CBlkCnt where type Unwrapped CBlkCnt = HTYPE_BLKCNT_T _Wrapped' = iso (\(CBlkCnt x) -> x) CBlkCnt {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_CLOCKID_T) instance Rewrapped CClockId t instance Wrapped CClockId where type Unwrapped CClockId = HTYPE_CLOCKID_T _Wrapped' = iso (\(CClockId x) -> x) CClockId {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_FSBLKCNT_T) instance Rewrapped CFsBlkCnt t instance Wrapped CFsBlkCnt where type Unwrapped CFsBlkCnt = HTYPE_FSBLKCNT_T _Wrapped' = iso (\(CFsBlkCnt x) -> x) CFsBlkCnt {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_FSFILCNT_T) instance Rewrapped CFsFilCnt t instance Wrapped CFsFilCnt where type Unwrapped CFsFilCnt = HTYPE_FSFILCNT_T _Wrapped' = iso (\(CFsFilCnt x) -> x) CFsFilCnt {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_ID_T) instance Rewrapped CId t instance Wrapped CId where type Unwrapped CId = HTYPE_ID_T _Wrapped' = iso (\(CId x) -> x) CId {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_KEY_T) instance Rewrapped CKey t instance Wrapped CKey where type Unwrapped CKey = HTYPE_KEY_T _Wrapped' = iso (\(CKey x) -> x) CKey {-# INLINE _Wrapped' #-} # endif # if defined(HTYPE_TIMER_T) instance Rewrapped CTimer t instance Wrapped CTimer where type Unwrapped CTimer = HTYPE_TIMER_T _Wrapped' = iso (\(CTimer x) -> x) CTimer {-# INLINE _Wrapped' #-} # endif #endif -- | Given the constructor for a t'Wrapped' type, return a -- deconstructor that is its inverse. -- -- Assuming the t'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 => (Unwrapped s -> s) -> s -> Unwrapped s op _ = view _Wrapped' {-# INLINE op #-} -- | This is a convenient version of '_Wrapped' with an argument that's ignored. -- -- The user supplied function is /ignored/, merely its type is used. _Wrapping' :: Wrapped s => (Unwrapped s -> s) -> Iso' s (Unwrapped s) _Wrapping' _ = _Wrapped' {-# INLINE _Wrapping' #-} -- | This is a convenient version of '_Wrapped' with an argument that's ignored. -- -- The user supplied function is /ignored/, merely its type is used. _Unwrapping' :: Wrapped s => (Unwrapped s -> s) -> Iso' (Unwrapped s) s _Unwrapping' _ = from _Wrapped' {-# INLINE _Unwrapping' #-} -- | This is a convenient version of '_Wrapped' with an argument that's ignored. -- -- The user supplied function is /ignored/, merely its types are used. _Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t) _Wrapping _ = _Wrapped {-# INLINE _Wrapping #-} -- | This is a convenient version of '_Unwrapped' with an argument that's ignored. -- -- The user supplied function is /ignored/, merely its types are used. _Unwrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso (Unwrapped t) (Unwrapped s) t s _Unwrapping _ = from _Wrapped {-# INLINE _Unwrapping #-} -- | This combinator is based on @ala@ from Conor McBride's work on Epigram. -- -- As with '_Wrapping', the user supplied function for the newtype is /ignored/. -- -- >>> 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 Product foldMap [1,2,3,4] -- 24 -- -- -- You may want to think of this combinator as having the following, simpler, type. -- -- @ -- ala :: Rewrapping s t => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> e -> s) -> e -> Unwrapped s -- @ ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s) ala f = xplat $ _Unwrapping f {-# 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 :: Rewrapping s t => (Unwrapped s -> s) -> ((r -> t) -> e -> s) -> (r -> Unwrapped t) -> e -> Unwrapped s -- @ -- -- >>> alaf Sum foldMap Prelude.length ["hello","world"] -- 10 alaf :: (Functor f, Functor g, Rewrapping s t) => (Unwrapped s -> s) -> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s) alaf f = xplatf $ _Unwrapping f {-# INLINE alaf #-} lens-5.2.3/src/Control/Lens/Zoom.hs0000644000000000000000000002674507346545000015261 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} #if !MIN_VERSION_transformers(0,6,0) {-# OPTIONS_GHC -Wno-warnings-deprecations #-} #endif #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Zoom -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ------------------------------------------------------------------------------- module Control.Lens.Zoom ( Magnified , Magnify(..) , Zoom(..) , Zoomed ) where import Prelude () import Control.Lens.Getter import Control.Lens.Internal.Prelude 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.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Free #if !MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif import Data.Kind -- $setup -- >>> import Control.Lens -- >>> import Control.Monad.State as State -- >>> import Control.Monad.Reader as Reader -- >>> import qualified Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> 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 -- Chosen so that they have lower fixity than ('%='), and to match ('<~'). infixr 2 `zoom`, `magnify` ------------------------------------------------------------------------------ -- Zoomed ------------------------------------------------------------------------------ -- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. type family Zoomed (m :: Type -> Type) :: Type -> Type -> Type 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 (MaybeT m) = FocusingMay (Zoomed m) type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m) type instance Zoomed (FreeT f m) = FocusingFree f m (Zoomed m) #if !MIN_VERSION_transformers(0,6,0) type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) #endif ------------------------------------------------------------------------------ -- Magnified ------------------------------------------------------------------------------ -- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. type family Magnified (m :: Type -> Type) :: Type -> Type -> Type type instance Magnified (ReaderT b m) = Effect m type instance Magnified ((->)b) = Const type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m type instance Magnified (IdentityT m) = Magnified m ------------------------------------------------------------------------------ -- Zoom ------------------------------------------------------------------------------ -- | 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 (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 '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 (MaybeT m) (MaybeT n) s t where zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #. l (FocusingMay #. afb)) . liftM May . runMaybeT {-# INLINE zoom #-} instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runExceptT {-# INLINE zoom #-} instance (Functor f, Zoom m n s t) => Zoom (FreeT f m) (FreeT f n) s t where zoom l = FreeT . liftM (fmap (zoom l) . getFreed) . zoom (\afb -> unfocusingFree #. l (FocusingFree #. afb)) . liftM Freed . runFreeT #if !MIN_VERSION_transformers(0,6,0) && !MIN_VERSION_mtl(2,3,0) 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 #-} 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 #-} #endif ------------------------------------------------------------------------------ -- Magnify ------------------------------------------------------------------------------ -- 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] -- -- The type can be read as -- -- @ -- magnify :: LensLike' (Magnified m c) a b -> m c -> n c -- @ -- -- but the higher-rank constraints make it easier to apply @magnify@ to a -- 'Getter' in highly-polymorphic code. -- -- @ -- '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 :: ((Functor (Magnified m c), Contravariant (Magnified m c)) => 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 l = views l {-# 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-5.2.3/src/Control/Monad/Error/0000755000000000000000000000000007346545000015211 5ustar0000000000000000lens-5.2.3/src/Control/Monad/Error/Lens.hs0000644000000000000000000002220007346545000016442 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Error.Lens -- Copyright : (C) 2014-2016 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, throwing_ ) where import Control.Applicative import Control.Lens import Control.Lens.Internal.Exception import Control.Monad import Control.Monad.Error.Class import Data.Functor.Plus import qualified Data.Monoid as M #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ -- | Catch exceptions that match a given t'Prism' (or any t'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 => t'Getter' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => t'Fold' e a -> m r -> (a -> m r) -> m r -- @ catching :: MonadError e m => Getting (M.First a) e a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} -- | Catch exceptions that match a given t'Prism' (or any t'Getter'), discarding -- the information about the match. This is particularly useful when you have -- a @'Prism'' e ()@ where the result of the t'Prism' or t'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 => t'Getter' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => t'Fold' e a -> m r -> m r -> m r -- @ catching_ :: MonadError e m => Getting (M.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 => t'Fold' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => t'Getter' e a -> (a -> m r) -> m r -> m r -- @ handling :: MonadError e m => Getting (M.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 => t'Getter' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => t'Fold' e a -> m r -> m r -> m r -- @ handling_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} ------------------------------------------------------------------------------ -- Trying ------------------------------------------------------------------------------ -- | 'trying' takes a t'Prism' (or any t'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 => t'Getter' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => t'Fold' e a -> m r -> m ('Either' a r) -- @ trying :: MonadError e m => Getting (M.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 (<>) = () {-# 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 => M.Monoid (Handler e m a) where mempty = zero {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) mappend = () {-# INLINE mappend #-} #endif instance Handleable e m (Handler e m) where handler = Handler . preview {-# INLINE handler #-} ------------------------------------------------------------------------------ -- Throwing ------------------------------------------------------------------------------ -- | Throw an exception described by a t'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 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 #-} -- | Similar to 'throwing' but specialised for the common case of -- error constructors with no arguments. -- -- @ -- data MyError = Foo | Bar -- makePrisms ''MyError -- 'throwing_' _Foo :: 'MonadError' MyError m => m a -- @ throwing_ :: MonadError e m => AReview e () -> m x throwing_ l = throwing l () {-# INLINE throwing_ #-} lens-5.2.3/src/Control/Parallel/Strategies/0000755000000000000000000000000007346545000016730 5ustar0000000000000000lens-5.2.3/src/Control/Parallel/Strategies/Lens.hs0000644000000000000000000000510107346545000020162 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Parallel.Strategies.Lens -- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A t'Lens' or t'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 t'Lens' or t'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 t'Lens' or t'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 parOf l s = l (rparWith s) {-# INLINE parOf #-} -- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'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 t'Lens', t'Fold', t'Getter', t'Setter' or t'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-5.2.3/src/Control/Seq/0000755000000000000000000000000007346545000013612 5ustar0000000000000000lens-5.2.3/src/Control/Seq/Lens.hs0000644000000000000000000000153707346545000015055 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Control.Seq.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- A t'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 t'Lens', t'Traversal', t'Iso', -- t'Getter' or t'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-5.2.3/src/Data/Array/0000755000000000000000000000000007346545000013371 5ustar0000000000000000lens-5.2.3/src/Data/Array/Lens.hs0000644000000000000000000000214507346545000014630 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Lens -- Copyright : (C) 2012-16 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 t'Setter' can be used to derive a new 'IArray' from an old 'IArray' by -- applying a function to each of the indices to look it up in the old 'IArray'. -- -- This is a /contravariant/ t'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 i = setting $ ixmap i {-# INLINE ixmapped #-} lens-5.2.3/src/Data/Bits/0000755000000000000000000000000007346545000013214 5ustar0000000000000000lens-5.2.3/src/Data/Bits/Lens.hs0000644000000000000000000002521007346545000014451 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Bits.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : LiberalTypeSynonyms -- ---------------------------------------------------------------------------- module Data.Bits.Lens ( (.|.~), (.&.~), (<.|.~), (<.&.~), (<<.|.~), (<<.&.~) , (.|.=), (.&.=), (<.|.=), (<.&.=), (<<.|.=), (<<.&.=) , bitAt , bits , byteAt , bytewise ) where import Prelude () import Control.Lens import Control.Lens.Internal.Prelude import Control.Monad.State import Data.Bits import Data.Word -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Word infixr 4 .|.~, .&.~, <.|.~, <.&.~, <<.|.~, <<.&.~ infix 4 .|.=, .&.=, <.|.=, <.&.=, <<.|.=, <<.&.= -- | Bitwise '.|.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .|.~ 6 $ ("hello",3) -- ("hello",7) -- -- @ -- ('.|.~') :: 'Bits' a => t'Setter' s t a a -> a -> s -> t -- ('.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> t -- ('.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> t -- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => t'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 t'Lens' or t'Setter'. -- -- >>> _2 .&.~ 7 $ ("hello",254) -- ("hello",6) -- -- @ -- ('.&.~') :: 'Bits' a => t'Setter' s t a a -> a -> s -> t -- ('.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> t -- ('.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> t -- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => t'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'', t'Setter' or t'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 t'Lens' (or t'Traversal'), returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.|.~ 6 $ ("hello",3) -- (7,("hello",7)) -- -- @ -- ('<.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) -- ('<.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) -- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'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 t'Lens' or t'Traversal', returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.&.~ 7 $ ("hello",254) -- (6,("hello",6)) -- -- @ -- ('<.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) -- ('<.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) -- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'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 t'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 (<.|.=) #-} -- | Bitwise '.&.' the target(s) of a t'Lens' or t'Traversal', and return the -- original value, or a monoidal summary of the original values. -- -- When you do not need the old value, ('.&.~') is more flexible. -- -- >>> _2 <<.&.~ 7 $ ("hello", 254) -- (254,("hello",6)) -- -- @ -- ('<<.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) -- ('<<.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) -- ('<<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<<.&.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.&.~ b = l $ \a -> (a, a .&. b) {-# INLINE (<<.&.~) #-} -- | Bitwise '.|.' the target(s) of a t'Lens' or t'Traversal', and return the -- original value, or a monoidal summary of the original values. -- -- When you do not need the old value, ('.|.~') is more flexible. -- -- >>> _2 <<.|.~ 6 $ ("hello", 3) -- (3,("hello",7)) -- -- @ -- ('<<.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) -- ('<<.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) -- ('<<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<<.|.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.|.~ b = l $ \a -> (a, a .|. b) {-# INLINE (<<.|.~) #-} -- | Modify the target(s) of a 'Lens'', (or 'Traversal'') by computing its -- bitwise '.&.' with another value, returning the original value (or a -- monoidal summary of all the original values). -- -- When you do not need the old value, ('.&.=') is more flexible. -- -- >>> runState (_1 <<.&.= 15) (31,0) -- (31,(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 %%= \a -> (a, a .&. b) {-# INLINE (<<.&.=) #-} -- | Modify the target(s) of a 'Lens'', (or 'Traversal'') by computing its -- bitwise '.|.' with another value, returning the original value (or a -- monoidal summary of all the original values). -- -- When you do not need the old value, ('.|.=') is more flexible. -- -- >>> runState (_1 <<.|.= 7) (28,0) -- (28,(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 %%= \a -> (a, a .|. b) {-# INLINE (<<.|.=) #-} -- | This t'Lens' can be used to access the value of the nth bit in a number. -- -- @'bitAt' n@ is only a legal t'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 t'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 t'Traversal', which -- can be productively consumed, but not reassembled. bits :: (Num b, Bits b) => IndexedTraversal' Int b Bool bits f b = foldr step 0 <$> traverse g bs where g n = (,) n <$> indexed f n (testBit b n) bs = 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 #-} -- | Traverse over all the bytes in an integral type, from the low end. -- -- The byte position is available as the index. -- -- >>> toListOf bytewise (1312301580 :: Word32) -- [12,34,56,78] -- -- If you supply this an 'Integer', the result will be an infinite t'Traversal', -- which can be productively consumed, but not reassembled. -- -- Why isn't this function called @bytes@ to match 'bits'? Alas, there -- is already a function by that name in "Data.ByteString.Lens". bytewise :: (Integral b, Bits b) => IndexedTraversal' Int b Word8 bytewise f b = foldr step 0 <$> traverse g bs where g n = (,) n <$> indexed f n (fromIntegral $ b `shiftR` (n*8)) bs = takeWhile hasByte [0..] hasByte n = complementBit b (n*8) /= b step (n,x) r = r .|. (fromIntegral x `shiftL` (n*8)) {-# INLINE bytewise #-} lens-5.2.3/src/Data/ByteString/Lazy/0000755000000000000000000000000007346545000015324 5ustar0000000000000000lens-5.2.3/src/Data/ByteString/Lazy/Lens.hs0000644000000000000000000001134207346545000016562 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lazy.Lens -- Copyright : (C) 2012-2016 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 , pattern Bytes , pattern Chars ) where import Control.Lens import Control.Lens.Internal.ByteString import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as Words import qualified Data.ByteString.Lazy.Char8 as Char8 import Data.Word (Word8) import Data.Int (Int64) -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens -- >>> import qualified Data.ByteString.Lazy.Char8 as Char8 -- | '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 Words.unpack {-# 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 t'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 -- -- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.Lazy.map'@ -- can be more efficient. 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 Char8.unpack {-# 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 t'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 #-} pattern Bytes :: [Word8] -> ByteString pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b pattern Chars :: String -> ByteString pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b lens-5.2.3/src/Data/ByteString/0000755000000000000000000000000007346545000014405 5ustar0000000000000000lens-5.2.3/src/Data/ByteString/Lens.hs0000644000000000000000000001206007346545000015641 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Lens ( IsByteString(..) , unpackedBytes , unpackedChars , pattern Bytes , pattern Chars ) where import Control.Lens import Data.Word (Word8) import qualified Data.ByteString as Strict import qualified Data.ByteString.Strict.Lens as Strict import qualified 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 t'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 t'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 #-} pattern Bytes :: IsByteString s => [Word8] -> s pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b pattern Chars :: IsByteString s => String -> s pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b -- | '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-5.2.3/src/Data/ByteString/Strict/0000755000000000000000000000000007346545000015655 5ustar0000000000000000lens-5.2.3/src/Data/ByteString/Strict/Lens.hs0000644000000000000000000001113007346545000017106 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens -- Copyright : (C) 2012-2016 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 , pattern Bytes , pattern Chars ) where import Control.Lens import Control.Lens.Internal.ByteString import Data.ByteString (ByteString) import qualified Data.ByteString as Words import qualified Data.ByteString.Char8 as Char8 import Data.Word -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens -- >>> import qualified Data.ByteString.Char8 as Char8 -- | '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 Words.unpack {-# 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 t'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 -- -- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.map'@ -- can be more efficient. bytes :: IndexedTraversal' Int ByteString Word8 bytes = traversedStrictTree {-# 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 Char8.unpack {-# 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 t'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 {-# INLINE chars #-} pattern Bytes :: [Word8] -> ByteString pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b pattern Chars :: String -> ByteString pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b lens-5.2.3/src/Data/Complex/0000755000000000000000000000000007346545000013722 5ustar0000000000000000lens-5.2.3/src/Data/Complex/Lens.hs0000644000000000000000000001015707346545000015163 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Complex.Lens -- Copyright : (C) 2012-16 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 -- * Pattern Synonyms , pattern Polar , pattern Real , pattern Imaginary , pattern Conjugate ) where import Prelude () import Control.Lens import Control.Lens.Internal.Prelude import Data.Complex -- $setup -- >>> import Control.Lens -- >>> import Data.Complex -- >>> 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)@ _realPart :: Lens' (Complex a) a _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)@ _imagPart :: Lens' (Complex a) a _imagPart f (a :+ b) = (a :+) <$> f b {-# INLINE _imagPart #-} -- | This isn't /quite/ a legal t'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 t'Lens'. _polar :: RealFloat a => Iso' (Complex a) (a,a) _polar = iso polar (uncurry mkPolar) {-# INLINE _polar #-} pattern Polar :: RealFloat a => a -> a -> Complex a pattern Polar m theta <- (view _polar -> (m, theta)) where Polar m theta = review _polar (m, theta) pattern Real :: (Eq a, Num a) => a -> Complex a pattern Real r = r :+ 0 pattern Imaginary :: (Eq a, Num a) => a -> Complex a pattern Imaginary i = 0 :+ i -- | Access the 'magnitude' of a 'Complex' number. -- -- >>> (10.0 :+ 20.0) & _magnitude *~ 2 -- 20.0 :+ 40.0 -- -- This isn't /quite/ a legal t'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 t'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 t'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 t'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 #-} pattern Conjugate :: Num a => Complex a -> Complex a pattern Conjugate a <- (conjugate -> a) where Conjugate a = conjugate a lens-5.2.3/src/Data/Data/0000755000000000000000000000000007346545000013164 5ustar0000000000000000lens-5.2.3/src/Data/Data/Lens.hs0000644000000000000000000003742307346545000014432 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fno-full-laziness #-} #if __GLASGOW_HASKELL__ >= 810 -- Use -fbyte-code explicitly to ensure that -fobject-code isn't automatically -- implied on GHCi 8.10+ by the use of UnboxedTuples, as this breaks the -- doctests. See #874 for more details. {-# OPTIONS_GHC -fbyte-code #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Data.Lens -- Copyright : (C) 2012-2016 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.Internal.Context import Control.Lens.Internal.Indexed import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type import Data.Data import GHC.IO import Data.Maybe 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#) import Prelude import qualified Data.Proxy as X (Proxy (..)) import qualified Data.Typeable as X (typeRep, eqT) import qualified Data.Type.Equality as X -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Lens.Internal.Doctest -- >>> import Prelude hiding (head, tail) ------------------------------------------------------------------------------- -- 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 :: forall s a f r. (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r step f w s = w <*> case X.eqT :: Maybe (s X.:~: a) of Just X.Refl -> f s 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 template = uniplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a) {-# 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 biplate = biplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a) {-# INLINE biplate #-} ------------------------------------------------------------------------------ -- Automatic Traversal construction from field accessors ------------------------------------------------------------------------------ data FieldException a = FieldException !Int a instance Show (FieldException a) where showsPrec d (FieldException i _) = showParen (d > 10) $ showString "' instance Typeable a => Exception (FieldException a) lookupon :: Typeable a => LensLike' (Indexing Identity) s a -> (s -> a) -> s -> Maybe (Int, Context a a s) lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexing l %@~ \i (a::a) -> E.throw (FieldException i a) of Right _ -> Nothing Left e -> case fromException e of 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' #-} ------------------------------------------------------------------------------- -- Data Box ------------------------------------------------------------------------------- data DataBox = forall a. Data a => DataBox { dataBoxKey :: TypeRep , _dataBoxVal :: a } dataBox :: Data a => a -> DataBox dataBox a = DataBox (X.typeRep [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 = X.typeRep (X.Proxy :: X.Proxy Rational) tInteger = X.typeRep (X.Proxy :: X.Proxy 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 = fromMaybe (hit ! x) (M.lookup 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 #-} -- | inlineable 'unsafePerformIO' inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-} ------------------------------------------------------------------------------- -- 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 b a = b ~ a => Hit a | Follow | Miss ------------------------------------------------------------------------------- -- Oracles ------------------------------------------------------------------------------- newtype Oracle a = Oracle { fromOracle :: forall t. Typeable t => t -> Answer t a } hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b hitTest a b = Oracle $ \(c :: c) -> case X.eqT :: Maybe (c X.:~: b) of Just X.Refl -> Hit c Nothing -> case readCacheFollower (dataBox a) (typeOf b) of Just p | not (p (typeOf c)) -> Miss _ -> Follow ------------------------------------------------------------------------------- -- Traversals ------------------------------------------------------------------------------- biplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s biplateData o f = go2 where go :: Data d => d -> f d go = gfoldl (\x y -> x <*> go2 y) pure go2 :: Data d => d -> f d go2 s = case o s of Hit a -> f a Follow -> go s Miss -> pure s {-# INLINE biplateData #-} uniplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s uniplateData o f = go where go :: Data d => d -> f d go = gfoldl (\x y -> x <*> go2 y) pure go2 :: Data d => d -> f d go2 s = case o s of Hit a -> 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)) lens-5.2.3/src/Data/Dynamic/0000755000000000000000000000000007346545000013677 5ustar0000000000000000lens-5.2.3/src/Data/Dynamic/Lens.hs0000644000000000000000000000320607346545000015135 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic.Lens -- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Dynamic.Lens ( AsDynamic(..) , pattern Data.Dynamic.Lens.Dynamic ) where import Control.Exception import Control.Exception.Lens import Control.Lens import Data.Dynamic -- | Any t'Dynamic' can be thrown as an t'Exception' class AsDynamic t where -- | This t'Prism' allows you to traverse the typed value contained in a -- t'Dynamic' where the type required by your function matches that -- of the contents of the t'Dynamic', or construct a t'Dynamic' value -- out of whole cloth. It can also be used to catch or throw a t'Dynamic' -- value as 'SomeException'. -- -- @ -- '_Dynamic' :: 'Typeable' a => 'Prism'' t'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 #-} pattern Dynamic :: (AsDynamic s, Typeable a) => a -> s pattern Dynamic a <- (preview _Dynamic -> Just a) where Dynamic a = review _Dynamic a lens-5.2.3/src/Data/HashSet/0000755000000000000000000000000007346545000013652 5ustar0000000000000000lens-5.2.3/src/Data/HashSet/Lens.hs0000644000000000000000000000406307346545000015112 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.HashSet.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.HashSet.Lens ( setmapped , setOf , hashMap ) where import Control.Lens.Getter (Getting, views) import Control.Lens.Iso (iso) import Control.Lens.Setter (setting) import Control.Lens.Type import qualified Data.HashSet as HashSet import Data.HashSet (HashSet, fromMap, toMap) import Data.HashMap.Lazy (HashMap) 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 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 #-} -- | An `Iso` between a `HashSet` and a `HashMap` with unit values. \(\mathcal{O}(1)\). hashMap :: Iso' (HashSet a) (HashMap a ()) hashMap = iso toMap fromMap lens-5.2.3/src/Data/IntSet/0000755000000000000000000000000007346545000013521 5ustar0000000000000000lens-5.2.3/src/Data/IntSet/Lens.hs0000644000000000000000000000377607346545000014773 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntSet.Lens -- Copyright : (C) 2012-16 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 qualified Data.IntSet as IntSet import Data.IntSet (IntSet) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import qualified Data.IntSet as IntSet -- | IntSet isn't Foldable, but this t'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 t'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 t'Traversal' for an 'IntSet', because the number of -- elements might change but you can manipulate it by reading using 'folded' and -- reindexing it via 'setmapped'. -- -- >>> over setmapped (+1) (IntSet.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 t'Getter', t'Fold', t'Traversal', t'Lens' or t'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' :: t'Getter' s 'Int' -> s -> 'IntSet' -- 'setOf' :: t'Fold' s 'Int' -> s -> 'IntSet' -- 'setOf' :: t'Iso'' s 'Int' -> s -> 'IntSet' -- 'setOf' :: t'Lens'' s 'Int' -> s -> 'IntSet' -- 'setOf' :: t'Traversal'' s 'Int' -> s -> 'IntSet' -- @ setOf :: Getting IntSet s Int -> s -> IntSet setOf l = views l IntSet.singleton {-# INLINE setOf #-} lens-5.2.3/src/Data/List/0000755000000000000000000000000007346545000013226 5ustar0000000000000000lens-5.2.3/src/Data/List/Lens.hs0000644000000000000000000000574207346545000014473 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Traversals for manipulating parts of a list. -- -- Additional optics for manipulating lists are present more -- generically in this package. -- -- The 'Control.Lens.At.Ixed' class allows traversing the element at a -- specific list index. -- -- >>> [0..10] ^? ix 4 -- Just 4 -- -- >>> [0..5] & ix 4 .~ 2 -- [0,1,2,3,2,5] -- -- >>> [0..10] ^? ix 14 -- Nothing -- -- >>> [0..5] & ix 14 .~ 2 -- [0,1,2,3,4,5] -- -- The 'Control.Lens.Cons.Cons' and 'Control.Lens.Empty.AsEmpty' -- classes provide 'Control.Lens.Prism.Prism's for list constructors. -- -- >>> [1..10] ^? _Cons -- Just (1,[2,3,4,5,6,7,8,9,10]) -- -- >>> [] ^? _Cons -- Nothing -- -- >>> [] ^? _Empty -- Just () -- -- >>> _Cons # (1, _Empty # ()) :: [Int] -- [1] -- -- Additionally, 'Control.Lens.Cons.Snoc' provides a -- 'Control.Lens.Prism.Prism' for accessing the end of a list. Note -- that this 'Control.Lens.Prism.Prism' always will need to traverse -- the whole list. -- -- >>> [1..5] ^? _Snoc -- Just ([1,2,3,4],5) -- -- >>> _Snoc # ([1,2],5) -- [1,2,5] -- -- An instance of 'Control.Lens.Plated.Plated' allows for finding -- locations in the list where a traversal matches. -- -- >>> [Nothing, Just 7, Just 3, Nothing] & deep (ix 0 . _Just) +~ 10 -- [Nothing,Just 17,Just 3,Nothing] -- -- An instance of 'Control.Lens.Iso.Reversing' provides an -- 'Control.Lens.Iso.Iso' between a list and its reverse. -- -- >>> "live" & reversed %~ ('d':) -- "lived" -- -- It's possible to work under a prefix or suffix of a list using -- 'Control.Lens.Prism.Prefixed' and 'Control.Lens.Prism.Suffixed'. -- -- >>> "preview" ^? prefixed "pre" -- Just "view" -- -- >>> suffixed ".o" # "hello" -- "hello.o" -- -- At present, "Data.List.Lens" re-exports 'Prefixed' and 'Suffixed' for -- backwards compatibility, as 'prefixed' and 'suffixed' used to be top-level -- functions defined in this module. This may change in a future major release -- of @lens@. -- -- Finally, it's possible to traverse, fold over, and map over -- index-value pairs thanks to instances of -- 'Control.Lens.Indexed.TraversableWithIndex', -- 'Control.Lens.Indexed.FoldableWithIndex', and -- 'Control.Lens.Indexed.FunctorWithIndex'. -- -- >>> imap (,) "Hello" -- [(0,'H'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] -- -- >>> ifoldMap replicate "Hello" -- "ellllloooo" -- -- >>> itraverse_ (curry print) "Hello" -- (0,'H') -- (1,'e') -- (2,'l') -- (3,'l') -- (4,'o') -- ---------------------------------------------------------------------------- module Data.List.Lens ( Prefixed(..) , Suffixed(..) , stripSuffix ) where import Control.Lens.Prism (Prefixed(..), Suffixed(..)) import Control.Lens.Internal.List (stripSuffix) --- $setup --- >>> :set -XNoOverloadedStrings --- >>> import Control.Lens lens-5.2.3/src/Data/Map/0000755000000000000000000000000007346545000013030 5ustar0000000000000000lens-5.2.3/src/Data/Map/Lens.hs0000644000000000000000000000701107346545000014264 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- One of most commonly-asked questions about this package is whether -- it provides lenses for working with 'Data.Map.Map'. It does, but their uses -- are perhaps obscured by their genericity. This module exists to provide -- documentation for them. -- -- 'Data.Map.Map' is an instance of 'Control.Lens.At.At', so we have a lenses -- on values at keys: -- -- >>> Map.fromList [(1, "world")] ^.at 1 -- Just "world" -- -- >>> at 1 .~ Just "world" $ Map.empty -- fromList [(1,"world")] -- -- >>> at 0 ?~ "hello" $ Map.empty -- fromList [(0,"hello")] -- -- We can traverse, fold over, and map over key-value pairs in a -- 'Data.Map.Map', thanks to its 'Control.Lens.Indexed.TraversableWithIndex', -- 'Control.Lens.Indexed.FoldableWithIndex', and -- 'Control.Lens.Indexed.FunctorWithIndex' instances. -- -- >>> imap const $ Map.fromList [(1, "Venus")] -- fromList [(1,1)] -- -- >>> ifoldMap (\i _ -> Sum i) $ Map.fromList [(2, "Earth"), (3, "Mars")] -- Sum {getSum = 5} -- -- >>> itraverse_ (curry print) $ Map.fromList [(4, "Jupiter")] -- (4,"Jupiter") -- -- >>> itoList $ Map.fromList [(5, "Saturn")] -- [(5,"Saturn")] -- -- A related class, 'Control.Lens.At.Ixed', allows us to use -- 'Control.Lens.At.ix' to traverse a value at a particular key. -- -- >>> ix 2 %~ ("New " ++) $ Map.fromList [(2, "Earth")] -- fromList [(2,"New Earth")] -- -- >>> preview (ix 8) $ Map.empty -- Nothing -- -- Additionally, 'Data.Map.Map' has 'Control.Lens.Traversal.TraverseMin' and -- 'Control.Lens.Traversal.TraverseMax' instances, which let us traverse over -- the value at the least and greatest keys, respectively. -- -- >>> preview traverseMin $ Map.fromList [(5, "Saturn"), (6, "Uranus")] -- Just "Saturn" -- -- >>> preview traverseMax $ Map.fromList [(5, "Saturn"), (6, "Uranus")] -- Just "Uranus" -- ----------------------------------------------------------------------------- module Data.Map.Lens ( toMapOf ) where import Control.Lens.Getter ( IndexedGetting, iviews ) import qualified Data.Map as Map -- $setup -- >>> import Control.Lens -- >>> import Data.Monoid -- >>> import qualified Data.Map as Map -- >>> :set -XNoOverloadedStrings -- | Construct a map from a 'IndexedGetter', 'Control.Lens.Fold.IndexedFold', 'Control.Lens.Traversal.IndexedTraversal' or 'Control.Lens.Lens.IndexedLens' -- -- The construction is left-biased (see 'Data.Map.Lazy.union'), i.e. the first -- occurrences of keys in the fold or traversal order are preferred. -- -- >>> toMapOf folded ["hello", "world"] -- fromList [(0,"hello"),(1,"world")] -- -- >>> toMapOf (folded . ifolded) [('a',"alpha"),('b', "beta")] -- fromList [('a',"alpha"),('b',"beta")] -- -- >>> toMapOf (folded <.> folded) ["foo", "bar"] -- fromList [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')] -- -- >>> toMapOf ifolded $ Map.fromList [('a', "hello"), ('b', "world")] -- fromList [('a',"hello"),('b',"world")] -- -- @ -- 'toMapOf' :: 'IndexedGetter' i s a -> s -> 'Map.Map' i a -- 'toMapOf' :: 'Ord' i => 'IndexedFold' i s a -> s -> 'Map.Map' i a -- 'toMapOf' :: 'IndexedLens'' i s a -> s -> 'Map.Map' i a -- 'toMapOf' :: 'Ord' i => 'IndexedTraversal'' i s a -> s -> 'Map.Map' i a -- @ toMapOf :: IndexedGetting i (Map.Map i a) s a -> s -> Map.Map i a toMapOf l = iviews l Map.singleton lens-5.2.3/src/Data/Sequence/0000755000000000000000000000000007346545000014063 5ustar0000000000000000lens-5.2.3/src/Data/Sequence/Lens.hs0000644000000000000000000001003407346545000015316 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Sequence.Lens -- Copyright : (C) 2012-16 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 , seqOf ) where import Control.Applicative import Control.Lens import Data.Monoid import qualified Data.Sequence as Seq import Data.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), (><), viewl, viewr) import Prelude -- $setup -- >>> import Control.Lens -- >>> import qualified Data.Sequence as Seq -- >>> import Data.Sequence (ViewL(EmptyL), ViewR(EmptyR)) -- >>> 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 Seq.:< Seq.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 Seq.:< 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 $ Seq.fromList [a,b] Seq.:> 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 Seq.:> a -> as Seq.|> a {-# INLINE viewR #-} -- | Traverse the first @n@ elements of a 'Seq' -- -- >>> Seq.fromList [a,b,c,d,e] ^.. slicedTo 2 -- [a,b] -- -- >>> Seq.fromList [a,b,c,d,e] & slicedTo 2 %~ f -- fromList [f a,f b,c,d,e] -- -- >>> Seq.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' -- -- >>> Seq.fromList [a,b,c,d,e] ^.. slicedFrom 2 -- [c,d,e] -- -- >>> Seq.fromList [a,b,c,d,e] & slicedFrom 2 %~ f -- fromList [a,b,f c,f d,f e] -- -- >>> Seq.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' -- -- >>> Seq.fromList [a,b,c,d,e] & sliced 1 3 %~ f -- fromList [a,f b,f c,d,e] -- >>> Seq.fromList [a,b,c,d,e] ^.. sliced 1 3 -- [f b,f c] -- -- >>> Seq.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 #-} -- | Construct a 'Seq' from a t'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. -- -- >>> seqOf folded ["hello","world"] -- fromList ["hello","world"] -- -- >>> seqOf (folded._2) [("hello",1),("world",2),("!!!",3)] -- fromList [1,2,3] -- -- @ -- 'seqOf' :: t'Getter' s a -> s -> 'Seq' a -- 'seqOf' :: t'Fold' s a -> s -> 'Seq' a -- 'seqOf' :: 'Iso'' s a -> s -> 'Seq' a -- 'seqOf' :: 'Lens'' s a -> s -> 'Seq' a -- 'seqOf' :: 'Traversal'' s a -> s -> 'Seq' a -- @ seqOf :: Getting (Seq a) s a -> s -> Seq a seqOf l = views l Seq.singleton {-# INLINE seqOf #-} lens-5.2.3/src/Data/Set/0000755000000000000000000000000007346545000013046 5ustar0000000000000000lens-5.2.3/src/Data/Set/Lens.hs0000644000000000000000000000372607346545000014313 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE Trustworthy #-} #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Lens -- Copyright : (C) 2012-16 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 qualified Data.Set as Set import Data.Set (Set) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import qualified Data.Set as Set -- | 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) (Set.fromList [1,2,3,4]) -- fromList [2,3,4,5] setmapped :: 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-5.2.3/src/Data/Text/Lazy/0000755000000000000000000000000007346545000014156 5ustar0000000000000000lens-5.2.3/src/Data/Text/Lazy/Lens.hs0000644000000000000000000001005007346545000015407 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lazy.Lens -- Copyright : (C) 2012-2016 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 , text , builder , utf8 , pattern Text ) where import Control.Lens.Type import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Setter import Control.Lens.Traversal import Data.ByteString.Lazy (ByteString) import Data.Monoid import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Encoding -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens -- >>> import qualified Data.ByteString.Lazy as ByteString -- | 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 Text.pack Text.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 Text.unpack Text.pack {-# INLINE unpacked #-} -- | This is an alias for 'unpacked' that makes it clearer how to use it with @('#')@. -- -- @ -- '_Text' = 'from' 'packed' -- @ -- -- >>> _Text # "hello" -- :: Text -- "hello" _Text :: Iso' Text String _Text = from packed {-# INLINE _Text #-} -- | Convert between lazy 'Text' and 'Builder' . -- -- @ -- 'fromLazyText' x ≡ x '^.' 'builder' -- 'toLazyText' x ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder builder = iso Builder.fromLazyText Builder.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' -- @ -- -- Note that when just using this as a 'Setter', @'setting' 'Data.Text.Lazy.map'@ -- can be more efficient. text :: IndexedTraversal' Int Text Char text = unpacked . traversed {-# INLINE [0] text #-} {-# RULES "lazy text -> map" text = sets Text.map :: ASetter' Text Char; "lazy text -> imap" text = isets imapLazy :: AnIndexedSetter' Int Text Char; "lazy text -> foldr" text = foldring Text.foldr :: Getting (Endo r) Text Char; "lazy text -> ifoldr" text = ifoldring ifoldrLazy :: IndexedGetting Int (Endo r) Text Char; #-} imapLazy :: (Int -> Char -> Char) -> Text -> Text imapLazy f = snd . Text.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 {-# INLINE imapLazy #-} ifoldrLazy :: (Int -> Char -> a -> a) -> a -> Text -> a ifoldrLazy f z xs = Text.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrLazy #-} -- | Encode\/Decode a lazy 'Text' to\/from lazy 'ByteString', via UTF-8. -- -- Note: This function does not decode lazily, as it must consume the entire -- input before deciding whether or not it fails. -- -- >>> ByteString.unpack (utf8 # "☃") -- [226,152,131] utf8 :: Prism' ByteString Text utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') {-# INLINE utf8 #-} pattern Text :: String -> Text pattern Text a <- (view _Text -> a) where Text a = review _Text a lens-5.2.3/src/Data/Text/0000755000000000000000000000000007346545000013237 5ustar0000000000000000lens-5.2.3/src/Data/Text/Lens.hs0000644000000000000000000000602407346545000014476 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lens ( IsText(..) , unpacked , _Text , pattern Text ) where import Control.Lens.Type import Control.Lens.Getter import Control.Lens.Review import Control.Lens.Iso import Control.Lens.Traversal import qualified Data.Text as Strict import qualified Data.Text.Strict.Lens as Strict import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.Lens as Lazy import Data.Text.Lazy.Builder (Builder) -- $setup -- >>> import Control.Lens -- >>> import qualified Data.Text as Strict -- | 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 #-} instance IsText String where packed = id {-# INLINE packed #-} text = traversed {-# INLINE text #-} builder = Lazy.packed . builder {-# INLINE builder #-} -- | 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 #-} -- | This is an alias for 'unpacked' that makes it clearer how to use it with @('#')@. -- -- @ -- '_Text' = 'from' 'packed' -- @ -- -- >>> _Text # "hello" :: Strict.Text -- "hello" _Text :: IsText t => Iso' t String _Text = from packed {-# INLINE _Text #-} pattern Text :: IsText s => String -> s pattern Text a <- (view _Text -> a) where Text a = review _Text a 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-5.2.3/src/Data/Text/Strict/0000755000000000000000000000000007346545000014507 5ustar0000000000000000lens-5.2.3/src/Data/Text/Strict/Lens.hs0000644000000000000000000000764107346545000015754 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Strict.Lens -- Copyright : (C) 2012-2016 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 , utf8 , _Text , pattern Text ) where import Control.Lens.Type import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Setter import Control.Lens.Traversal import Data.ByteString (ByteString) import Data.Monoid import qualified Data.Text as Strict import Data.Text (Text) import Data.Text.Encoding import Data.Text.Lazy (toStrict) import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder (Builder) -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens -- | 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 Strict.pack Strict.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 Strict.unpack Strict.pack {-# INLINE unpacked #-} -- | This is an alias for 'unpacked' that makes it more obvious how to use it with '#' -- -- >> _Text # "hello" -- :: Text -- "hello" _Text :: Iso' Text String _Text = unpacked {-# INLINE _Text #-} -- | Convert between strict 'Text' and 'Builder' . -- -- @ -- 'fromText' x ≡ x '^.' 'builder' -- 'toStrict' ('toLazyText' x) ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder builder = iso Builder.fromText (toStrict . Builder.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' -- @ -- -- Note that when just using this as a 'Setter', @'setting' 'Data.Text.map'@ can -- be more efficient. text :: IndexedTraversal' Int Text Char text = unpacked . traversed {-# INLINE [0] text #-} {-# RULES "strict text -> map" text = sets Strict.map :: ASetter' Text Char; "strict text -> imap" text = isets imapStrict :: AnIndexedSetter' Int Text Char; "strict text -> foldr" text = foldring Strict.foldr :: Getting (Endo r) Text Char; "strict text -> ifoldr" text = ifoldring ifoldrStrict :: IndexedGetting Int (Endo r) Text Char; #-} imapStrict :: (Int -> Char -> Char) -> Text -> Text imapStrict f = snd . Strict.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 {-# INLINE imapStrict #-} ifoldrStrict :: (Int -> Char -> a -> a) -> a -> Text -> a ifoldrStrict f z xs = Strict.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrStrict #-} -- | Encode\/Decode a strict 'Text' to\/from strict 'ByteString', via UTF-8. -- -- >>> utf8 # "☃" -- "\226\152\131" utf8 :: Prism' ByteString Text utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') {-# INLINE utf8 #-} pattern Text :: String -> Text pattern Text a <- (view _Text -> a) where Text a = review _Text a lens-5.2.3/src/Data/Tree/0000755000000000000000000000000007346545000013212 5ustar0000000000000000lens-5.2.3/src/Data/Tree/Lens.hs0000644000000000000000000000201407346545000014444 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MTPCs -- ---------------------------------------------------------------------------- module Data.Tree.Lens ( root , branches ) where import Prelude () import Control.Lens.Internal.Prelude import Control.Lens import Data.Tree -- $setup -- >>> import Control.Lens -- >>> import Data.Tree -- | A t'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 t'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-5.2.3/src/Data/Typeable/0000755000000000000000000000000007346545000014060 5ustar0000000000000000lens-5.2.3/src/Data/Typeable/Lens.hs0000644000000000000000000000217707346545000015324 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Typeable.Lens -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Typeable.Lens ( _cast , _gcast ) where import Prelude () import Control.Lens import Control.Lens.Internal.Prelude import Data.Maybe (fromMaybe) import Data.Typeable -- | 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-5.2.3/src/Data/Vector/Generic/0000755000000000000000000000000007346545000015131 5ustar0000000000000000lens-5.2.3/src/Data/Vector/Generic/Lens.hs0000644000000000000000000001206607346545000016373 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #include "lens-common.h" ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Generic.Lens -- Copyright : (C) 2012-2016 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 , converted -- * Lenses , sliced -- * Traversal of individual indices , ordinals , vectorIx , vectorTraverse ) where import Prelude () import Control.Lens.Type import Control.Lens.Lens import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Indexed import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Internal.List (ordinalNub) import Control.Lens.Internal.Prelude import Data.Vector.Fusion.Bundle (Bundle) import qualified Data.Vector.Generic as V import Data.Vector.Generic (Vector) import Data.Vector.Generic.New (New) -- $setup -- >>> import qualified Data.Vector as Vector -- >>> import Control.Lens -- | @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 == Vector.fromList [3,4,5,6,7] -- True -- -- >>> (Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10] -- True sliced :: Vector v a => Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Lens' (v a) (v a) sliced i n f v = f (V.slice i n v) <&> \ v0 -> v 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) == Vector.fromList [8,15] -- True toVectorOf :: Vector v a => Getting (Endo [a]) s a -> s -> v a toVectorOf l s = V.fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back.) -- -- >>> ([1,2,3] ^. vector :: Vector.Vector Int) == Vector.fromList [1,2,3] -- True -- -- >>> Vector.fromList [0,8,15] ^. from vector -- [0,8,15] vector :: (Vector v a, Vector v b) => Iso [a] [b] (v a) (v b) vector = iso V.fromList V.toList {-# INLINE vector #-} -- | Convert a 'Vector' to a finite 'Bundle' (or back.) asStream :: (Vector v a, Vector v b) => Iso (v a) (v b) (Bundle v a) (Bundle v b) asStream = iso V.stream V.unstream {-# INLINE asStream #-} -- | Convert a 'Vector' to a finite 'Bundle' from right to left (or -- back.) asStreamR :: (Vector v a, Vector v b) => Iso (v a) (v b) (Bundle v a) (Bundle v b) asStreamR = iso V.streamR V.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 V.clone V.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 V.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 V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (V.length v) is {-# INLINE ordinals #-} -- | Like 'ix' but polymorphic in the vector type. vectorIx :: V.Vector v a => Int -> Traversal' (v a) a vectorIx i f v | 0 <= i && i < V.length v = f (v V.! i) <&> \a -> v V.// [(i, a)] | otherwise = pure v {-# INLINE vectorIx #-} -- | Indexed vector traversal for a generic vector. vectorTraverse :: (V.Vector v a, V.Vector w b) => IndexedTraversal Int (v a) (w b) a b vectorTraverse f v = V.fromListN (V.length v) <$> traversed f (V.toList v) {-# INLINE [0] vectorTraverse #-} {-# RULES "vectorTraverse -> mapped" vectorTraverse = sets V.map :: (V.Vector v a, V.Vector v b) => ASetter (v a) (v b) a b; "vectorTraverse -> imapped" vectorTraverse = isets V.imap :: (V.Vector v a, V.Vector v b) => AnIndexedSetter Int (v a) (v b) a b; "vectorTraverse -> foldr" vectorTraverse = foldring V.foldr :: V.Vector v a => Getting (Endo r) (v a) a; "vectorTraverse -> ifoldr" vectorTraverse = ifoldring V.ifoldr :: V.Vector v a => IndexedGetting Int (Endo r) (v a) a; #-} -- | Different vector implementations are isomorphic to each other. converted :: (Vector v a, Vector w a, Vector v b, Vector w b) => Iso (v a) (v b) (w a) (w b) converted = iso V.convert V.convert lens-5.2.3/src/Data/Vector/0000755000000000000000000000000007346545000013555 5ustar0000000000000000lens-5.2.3/src/Data/Vector/Lens.hs0000644000000000000000000000564707346545000015026 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Lens -- Copyright : (C) 2012-16 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 Prelude () import Control.Lens import Control.Lens.Internal.List (ordinalNub) import Control.Lens.Internal.Prelude import qualified Data.Vector as V import Data.Vector (Vector) -- $setup -- >>> import qualified Data.Vector as Vector -- >>> import Control.Lens -- | @sliced i n@ provides a t'Lens' that edits the @n@ elements starting -- at index @i@ from a t'Lens'. -- -- This is only a valid t'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 t'Lens' laws. -- -- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] -- True -- -- >>> (Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10] -- True sliced :: Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Lens' (Vector a) (Vector a) sliced i n f v = f (V.slice i n v) <&> \ v0 -> v V.// zip [i..i+n-1] (V.toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'. -- -- >>> toVectorOf both (8,15) == Vector.fromList [8,15] -- True toVectorOf :: Getting (Endo [a]) s a -> s -> Vector a toVectorOf l s = V.fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back) -- -- >>> [1,2,3] ^. vector == Vector.fromList [1,2,3] -- True -- -- >>> [1,2,3] ^. vector . from vector -- [1,2,3] -- -- >>> Vector.fromList [0,8,15] ^. from vector . vector == Vector.fromList [0,8,15] -- True vector :: Iso [a] [b] (Vector a) (Vector b) vector = iso V.fromList V.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 V.force V.force {-# INLINE forced #-} -- | This t'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 V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (length v) is {-# INLINE ordinals #-} lens-5.2.3/src/GHC/Generics/0000755000000000000000000000000007346545000013602 5ustar0000000000000000lens-5.2.3/src/GHC/Generics/Lens.hs0000644000000000000000000001004307346545000015035 0ustar0000000000000000{-# LANGUAGE EmptyCase #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens -- Copyright : (C) 2012-16 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 ( generic , generic1 , _V1 , _U1 , _Par1 , _Rec1 , _K1 , _M1 , _L1 , _R1 , _UAddr , _UChar , _UDouble , _UFloat , _UInt , _UWord ) where import Control.Lens import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Ptr(..), Word(..)) import qualified GHC.Generics as Generic import GHC.Generics hiding (from, to) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- | Convert from the data type to its representation (or back) -- -- >>> "hello"^.generic.from generic :: String -- "hello" generic :: (Generic a, Generic b) => Iso a b (Rep a g) (Rep b h) generic = iso Generic.from Generic.to {-# INLINE generic #-} -- | Convert from the data type to its representation (or back) generic1 :: (Generic1 f, Generic1 g) => Iso (f a) (g b) (Rep1 f a) (Rep1 g b) generic1 = iso from1 to1 {-# INLINE generic1 #-} _V1 :: Over p f (V1 s) (V1 t) a b _V1 _ = \case {-# INLINE _V1 #-} _U1 :: Iso (U1 p) (U1 q) () () _U1 = iso (const ()) (const U1) {-# INLINE _U1 #-} _Par1 :: Iso (Par1 p) (Par1 q) p q _Par1 = coerced {-# INLINE _Par1 #-} _Rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q) _Rec1 = coerced {-# INLINE _Rec1 #-} _K1 :: Iso (K1 i c p) (K1 j d q) c d _K1 = coerced {-# INLINE _K1 #-} _M1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q) _M1 = coerced {-# INLINE _M1 #-} _L1 :: Prism' ((f :+: g) a) (f a) _L1 = prism remitter reviewer where remitter = L1 reviewer (L1 l) = Right l reviewer x = Left x {-# INLINE _L1 #-} -- | You can access fields of `data (f :*: g) p` by using its `Field1` and -- `Field2` instances. _R1 :: Prism' ((f :+: g) a) (g a) _R1 = prism remitter reviewer where remitter = R1 reviewer (R1 l) = Right l reviewer x = Left x {-# INLINE _R1 #-} _UAddr :: Iso (UAddr p) (UAddr q) (Ptr c) (Ptr d) _UAddr = iso remitter reviewer where remitter (UAddr a) = Ptr a reviewer (Ptr a) = UAddr a {-# INLINE _UAddr #-} _UChar :: Iso (UChar p) (UChar q) Char Char _UChar = iso remitter reviewer where remitter (UChar c) = C# c reviewer (C# c) = UChar c {-# INLINE _UChar #-} _UDouble :: Iso (UDouble p) (UDouble q) Double Double _UDouble = iso remitter reviewer where remitter (UDouble d) = D# d reviewer (D# d) = UDouble d {-# INLINE _UDouble #-} _UFloat :: Iso (UFloat p) (UFloat q) Float Float _UFloat = iso remitter reviewer where remitter (UFloat f) = F# f reviewer (F# f) = UFloat f {-# INLINE _UFloat #-} _UInt :: Iso (UInt p) (UInt q) Int Int _UInt = iso remitter reviewer where remitter (UInt i) = I# i reviewer (I# i) = UInt i {-# INLINE _UInt #-} _UWord :: Iso (UWord p) (UWord q) Word Word _UWord = iso remitter reviewer where remitter (UWord w) = W# w reviewer (W# w) = UWord w {-# INLINE _UWord #-} lens-5.2.3/src/Language/Haskell/TH/0000755000000000000000000000000007346545000015063 5ustar0000000000000000lens-5.2.3/src/Language/Haskell/TH/Lens.hs0000644000000000000000000021617607346545000016335 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE Rank2Types #-} #include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Lens -- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : TemplateHaskell -- -- Lenses, Prisms, and Traversals for working with Template Haskell. -- -- Beware that the API offered in this module is subject to change, as it -- mirrors the API exposed by the @template-haskell@ package, which -- frequently changes between different releases of GHC. An effort is made -- to identify the functions in this module which have different type -- signatures when compiled with different versions of @template-haskell@. ---------------------------------------------------------------------------- module Language.Haskell.TH.Lens ( -- * Traversals HasName(..) , HasTypes(..) , HasTypeVars(..) , SubstType(..) , typeVars -- :: HasTypeVars t => Traversal' t Name , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t , conFields , conNamedFields -- * Lenses -- ** Loc Lenses , locFileName , locPackage , locModule , locStart , locEnd -- ** FunDep Lenses , funDepInputs , funDepOutputs -- ** Match Lenses , matchPattern , matchBody , matchDeclarations -- ** Fixity Lenses , fixityPrecedence , fixityDirection -- ** Clause Lenses , clausePattern , clauseBody , clauseDecs -- ** FieldExp Lenses , fieldExpName , fieldExpExpression -- ** FieldPat Lenses , fieldPatName , fieldPatPattern -- ** TySynEqn Lenses # if MIN_VERSION_template_haskell(2,15,0) , tySynEqnLHS # endif , tySynEqnPatterns , tySynEqnResult -- ** InjectivityAnn Lenses , injectivityAnnOutput , injectivityAnnInputs -- ** TypeFamilyHead Lenses , typeFamilyHeadName , typeFamilyHeadTyVarBndrs , typeFamilyHeadResultSig , typeFamilyHeadInjectivityAnn -- ** Bang Lenses , bangSourceUnpackedness , bangSourceStrictness #if MIN_VERSION_template_haskell(2,12,0) -- ** DerivClause Lenses , derivClauseStrategy , derivClauseCxt #endif -- * Prisms -- ** Info Prisms , _ClassI , _ClassOpI , _TyConI , _FamilyI , _PrimTyConI , _DataConI , _VarI , _TyVarI #if MIN_VERSION_template_haskell(2,12,0) , _PatSynI #endif -- ** Dec Prisms , _FunD , _ValD , _DataD , _NewtypeD , _TySynD , _ClassD , _InstanceD , _SigD , _ForeignD , _InfixD , _PragmaD , _DataInstD , _NewtypeInstD , _TySynInstD , _ClosedTypeFamilyD , _RoleAnnotD , _StandaloneDerivD , _DefaultSigD , _DataFamilyD , _OpenTypeFamilyD #if MIN_VERSION_template_haskell(2,12,0) , _PatSynD , _PatSynSigD #endif #if MIN_VERSION_template_haskell(2,15,0) , _ImplicitParamBindD #endif #if MIN_VERSION_template_haskell(2,19,0) , _DefaultD #endif #if MIN_VERSION_template_haskell(2,20,0) , _TypeDataD #endif #if MIN_VERSION_template_haskell(2,12,0) -- ** PatSynDir Prisms , _Unidir , _ImplBidir , _ExplBidir -- ** PatSynArgs Prisms , _PrefixPatSyn , _InfixPatSyn , _RecordPatSyn #endif -- ** Con Prisms , _NormalC , _RecC , _InfixC , _ForallC , _GadtC , _RecGadtC -- ** Overlap Prisms ,_Overlappable ,_Overlapping ,_Overlaps ,_Incoherent -- ** SourceUnpackedness Prisms , _NoSourceUnpackedness , _SourceNoUnpack , _SourceUnpack -- ** SourceStrictness Prisms , _NoSourceStrictness , _SourceLazy , _SourceStrict -- ** DecidedStrictness Prisms , _DecidedLazy , _DecidedStrict , _DecidedUnpack -- ** Foreign Prisms , _ImportF , _ExportF -- ** Callconv Prisms , _CCall , _StdCall , _CApi , _Prim , _JavaScript -- ** Safety Prisms , _Unsafe , _Safe , _Interruptible -- ** Pragma Prisms , _InlineP , _SpecialiseP , _SpecialiseInstP , _RuleP , _AnnP , _LineP #if MIN_VERSION_template_haskell(2,12,0) , _CompleteP #endif #if MIN_VERSION_template_haskell(2,19,0) , _OpaqueP #endif -- ** Inline Prisms , _NoInline , _Inline , _Inlinable -- ** RuleMatch Prisms , _ConLike , _FunLike -- ** Phases Prisms , _AllPhases , _FromPhase , _BeforePhase -- ** RuleBndr Prisms , _RuleVar , _TypedRuleVar -- ** AnnTarget Prisms , _ModuleAnnotation , _TypeAnnotation , _ValueAnnotation -- ** FunDep Prisms TODO make a lens , _FunDep #if !(MIN_VERSION_template_haskell(2,13,0)) -- ** FamFlavour Prisms , _TypeFam , _DataFam #endif -- ** FixityDirection Prisms , _InfixL , _InfixR , _InfixN -- ** Exp Prisms , _VarE , _ConE , _LitE , _AppE #if MIN_VERSION_template_haskell(2,12,0) , _AppTypeE #endif , _InfixE , _UInfixE , _ParensE , _LamE , _LamCaseE , _TupE , _UnboxedTupE #if MIN_VERSION_template_haskell(2,12,0) , _UnboxedSumE #endif , _CondE , _MultiIfE , _LetE , _CaseE , _DoE , _CompE , _ArithSeqE , _ListE , _SigE , _RecConE , _RecUpdE , _StaticE , _UnboundVarE #if MIN_VERSION_template_haskell(2,13,0) , _LabelE #endif #if MIN_VERSION_template_haskell(2,15,0) , _MDoE , _ImplicitParamVarE #endif #if MIN_VERSION_template_haskell(2,18,0) , _GetFieldE , _ProjectionE #endif #if MIN_VERSION_template_haskell(2,19,0) , _LamCasesE #endif #if MIN_VERSION_template_haskell(2,21,0) , _TypedBracketE , _TypedSpliceE #endif -- ** Body Prisms , _GuardedB , _NormalB -- ** Guard Prisms , _NormalG , _PatG -- ** Stmt Prisms , _BindS , _LetS , _NoBindS , _ParS #if MIN_VERSION_template_haskell(2,15,0) , _RecS #endif -- ** Range Prisms , _FromR , _FromThenR , _FromToR , _FromThenToR -- ** Lit Prisms , _CharL , _StringL , _IntegerL , _RationalL , _IntPrimL , _WordPrimL , _FloatPrimL , _DoublePrimL , _StringPrimL , _CharPrimL #if MIN_VERSION_template_haskell(2,16,0) , _BytesPrimL #endif -- ** Pat Prisms , _LitP , _VarP , _TupP , _UnboxedTupP #if MIN_VERSION_template_haskell(2,12,0) , _UnboxedSumP #endif , _ConP , _InfixP , _UInfixP , _ParensP , _TildeP , _BangP , _AsP , _WildP , _RecP , _ListP , _SigP , _ViewP -- ** Type Prisms , _ForallT , _AppT , _SigT , _VarT , _ConT , _PromotedT , _TupleT , _UnboxedTupleT #if MIN_VERSION_template_haskell(2,12,0) , _UnboxedSumT #endif , _ArrowT , _EqualityT , _ListT , _PromotedTupleT , _PromotedNilT , _PromotedConsT , _StarT , _ConstraintT , _LitT , _InfixT , _UInfixT , _ParensT , _WildCardT #if MIN_VERSION_template_haskell(2,15,0) , _AppKindT , _ImplicitParamT #endif #if MIN_VERSION_template_haskell(2,16,0) , _ForallVisT #endif #if MIN_VERSION_template_haskell(2,17,0) , _MulArrowT #endif #if MIN_VERSION_template_haskell(2,19,0) , _PromotedInfixT , _PromotedUInfixT #endif #if MIN_VERSION_template_haskell(2,17,0) -- ** Specificity Prisms , _SpecifiedSpec , _InferredSpec #endif #if MIN_VERSION_template_haskell(2,21,0) -- ** BndrVis Prisms , _BndrReq , _BndrInvis #endif -- ** TyVarBndr Prisms , _PlainTV , _KindedTV -- ** FamilyResultSig Prisms , _NoSig , _KindSig , _TyVarSig -- ** TyLit Prisms , _NumTyLit , _StrTyLit #if MIN_VERSION_template_haskell(2,18,0) , _CharTyLit #endif -- ** Role Prisms , _NominalR , _RepresentationalR , _PhantomR , _InferR #if MIN_VERSION_template_haskell(2,12,0) -- ** DerivStrategy Prisms , _StockStrategy , _AnyclassStrategy , _NewtypeStrategy #endif ) where import Control.Applicative import Control.Lens.At import Control.Lens.Getter import Control.Lens.Setter import Control.Lens.Fold import Control.Lens.Internal.TH import Control.Lens.Iso (Iso', iso) import Control.Lens.Lens import Control.Lens.Prism import Control.Lens.Tuple import Control.Lens.Traversal import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Set as Set import Data.Set (Set) import Data.Set.Lens import Language.Haskell.TH import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Syntax import Data.Word #if MIN_VERSION_template_haskell(2,15,0) import Data.Foldable as F (foldl') #endif #if MIN_VERSION_template_haskell(2,18,0) import Data.List.NonEmpty (NonEmpty) #endif import Prelude -- | Has a 'Name' class HasName t where -- | Extract (or modify) the 'Name' of something name :: Lens' t Name instance HasName (TyVarBndr_ flag) where name = traverseTVName instance HasName Name where name = id -- | On @template-haskell-2.11.0.0@ or later, if a 'GadtC' or 'RecGadtC' has -- multiple 'Name's, the leftmost 'Name' will be chosen. 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 name f (GadtC ns argTys retTy) = (\n -> GadtC [n] argTys retTy) <$> f (headGadtConName ns) name f (RecGadtC ns argTys retTy) = (\n -> RecGadtC [n] argTys retTy) <$> f (headGadtConName ns) -- @template-haskell@ maintains the invariant that the list of constructor -- @Name@s in a 'GadtC' or 'RecGadtC' will always be non-empty. headGadtConName :: [Name] -> Name headGadtConName conNames = case conNames of conName:_ -> conName [] -> error "headGadtConName: Unexpected empty list of GADT constructor names" instance HasName Foreign where name f (ImportF cc saf str n ty) = (\n' -> ImportF cc saf str n' ty) <$> f n name f (ExportF cc str n ty) = (\n' -> ExportF cc str n' ty) <$> f n instance HasName RuleBndr where name f (RuleVar n) = RuleVar <$> f n name f (TypedRuleVar n ty) = (`TypedRuleVar` ty) <$> f n instance HasName TypeFamilyHead where name f (TypeFamilyHead n tvbs frs mia) = (\n' -> TypeFamilyHead n' tvbs frs mia) <$> f n instance HasName InjectivityAnn where name f (InjectivityAnn n deps) = (`InjectivityAnn` deps) <$> f n -- | Contains some amount of `Type`s inside class HasTypes t where -- | Traverse all the types types :: Traversal' t Type instance HasTypes Type where types = id instance HasTypes Con where types f (NormalC n t) = NormalC n <$> traverse (_2 (types f)) t types f (RecC n t) = RecC n <$> traverse (_3 (types f)) t types f (InfixC t1 n t2) = InfixC <$> _2 (types f) t1 <*> pure n <*> _2 (types f) t2 types f (ForallC vb ctx con) = ForallC vb ctx <$> types f con types f (GadtC ns argTys retTy) = GadtC ns <$> traverse (_2 (types f)) argTys <*> types f retTy types f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverse (_3 (types f)) argTys <*> types f retTy instance HasTypes Foreign where types f (ImportF cc saf str n t) = ImportF cc saf str n <$> types f t types f (ExportF cc str n t) = ExportF cc str n <$> types f t instance HasTypes TySynEqn where #if MIN_VERSION_template_haskell(2,15,0) types f (TySynEqn mtvbs lhs rhs) = TySynEqn <$> traverse (traverse go) mtvbs <*> types f lhs <*> types f rhs where go = traverseTVKind f #else types f (TySynEqn lhss rhs) = TySynEqn <$> traverse (types f) lhss <*> types f rhs #endif instance HasTypes t => HasTypes [t] where types = traverse . types -- | 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_ flag) 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 (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty where s' = s `Set.union` setOf typeVars bs typeVarsEx _ _ t@ConT{} = pure t typeVarsEx _ _ t@TupleT{} = pure t typeVarsEx _ _ t@ListT{} = pure t typeVarsEx _ _ t@ArrowT{} = pure t typeVarsEx _ _ t@UnboxedTupleT{} = pure t typeVarsEx s f (SigT t k) = SigT <$> typeVarsEx s f t <*> typeVarsEx s f k typeVarsEx _ _ t@PromotedT{} = pure t typeVarsEx _ _ t@PromotedTupleT{} = pure t typeVarsEx _ _ t@PromotedNilT{} = pure t typeVarsEx _ _ t@PromotedConsT{} = pure t typeVarsEx _ _ t@StarT{} = pure t typeVarsEx _ _ t@ConstraintT{} = pure t typeVarsEx _ _ t@LitT{} = pure t typeVarsEx _ _ t@EqualityT{} = pure t typeVarsEx s f (InfixT t1 n t2) = InfixT <$> typeVarsEx s f t1 <*> pure n <*> typeVarsEx s f t2 typeVarsEx s f (UInfixT t1 n t2) = UInfixT <$> typeVarsEx s f t1 <*> pure n <*> typeVarsEx s f t2 typeVarsEx s f (ParensT t) = ParensT <$> typeVarsEx s f t typeVarsEx _ _ t@WildCardT{} = pure t #if MIN_VERSION_template_haskell(2,12,0) typeVarsEx _ _ t@UnboxedSumT{} = pure t #endif #if MIN_VERSION_template_haskell(2,15,0) typeVarsEx s f (AppKindT t k) = AppKindT <$> typeVarsEx s f t <*> typeVarsEx s f k typeVarsEx s f (ImplicitParamT n t) = ImplicitParamT n <$> typeVarsEx s f t #endif #if MIN_VERSION_template_haskell(2,16,0) typeVarsEx s f (ForallVisT bs ty) = ForallVisT bs <$> typeVarsEx s' f ty where s' = s `Set.union` setOf typeVars bs #endif #if MIN_VERSION_template_haskell(2,17,0) typeVarsEx _ _ t@MulArrowT{} = pure t #endif #if MIN_VERSION_template_haskell(2,19,0) typeVarsEx s f (PromotedInfixT t1 n t2) = PromotedInfixT <$> typeVarsEx s f t1 <*> pure n <*> typeVarsEx s f t2 typeVarsEx s f (PromotedUInfixT t1 n t2) = PromotedUInfixT <$> typeVarsEx s f t1 <*> pure n <*> typeVarsEx s f t2 #endif 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 typeVarsEx s f (GadtC ns argTys retTy) = GadtC ns <$> traverseOf (traverse . _2) (typeVarsEx s f) argTys <*> typeVarsEx s f retTy typeVarsEx s f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverseOf (traverse . _3) (typeVarsEx s f) argTys <*> typeVarsEx s f retTy instance HasTypeVars t => HasTypeVars [t] where typeVarsEx s = traverse . typeVarsEx s instance HasTypeVars t => HasTypeVars (Maybe 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 _ t@ConT{} = t substType _ t@TupleT{} = t substType _ t@ListT{} = t substType _ t@ArrowT{} = t substType _ t@UnboxedTupleT{} = t substType m (AppT l r) = AppT (substType m l) (substType m r) substType m (SigT t k) = SigT (substType m t) (substType m k) substType _ t@PromotedT{} = t substType _ t@PromotedTupleT{} = t substType _ t@PromotedNilT{} = t substType _ t@PromotedConsT{} = t substType _ t@StarT{} = t substType _ t@ConstraintT{} = t substType _ t@LitT{} = t substType _ t@EqualityT{} = t substType m (InfixT t1 n t2) = InfixT (substType m t1) n (substType m t2) substType m (UInfixT t1 n t2) = UInfixT (substType m t1) n (substType m t2) substType m (ParensT t) = ParensT (substType m t) substType _ t@WildCardT{} = t #if MIN_VERSION_template_haskell(2,12,0) substType _ t@UnboxedSumT{} = t #endif #if MIN_VERSION_template_haskell(2,15,0) substType m (AppKindT t k) = AppKindT (substType m t) (substType m k) substType m (ImplicitParamT n t) = ImplicitParamT n (substType m t) #endif #if MIN_VERSION_template_haskell(2,16,0) substType m (ForallVisT bs ty) = ForallVisT bs (substType m' ty) where m' = foldrOf typeVars Map.delete m bs #endif #if MIN_VERSION_template_haskell(2,17,0) substType _ t@MulArrowT{} = t #endif #if MIN_VERSION_template_haskell(2,19,0) substType m (PromotedInfixT t1 n t2) = PromotedInfixT (substType m t1) n (substType m t2) substType m (PromotedUInfixT t1 n t2) = PromotedUInfixT (substType m t1) n (substType m t2) #endif instance SubstType t => SubstType [t] where substType = map . substType -- | Provides a 'Traversal' of the types of each field of a constructor. conFields :: Traversal' Con BangType conFields f (NormalC n fs) = NormalC n <$> traverse f fs conFields f (RecC n fs) = RecC n <$> traverse (sansVar f) fs 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 conFields f (GadtC ns argTys retTy) = GadtC ns <$> traverse f argTys <*> pure retTy conFields f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverse (sansVar f) argTys <*> pure retTy sansVar :: Traversal' VarBangType BangType sansVar f (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t) -- | 'Traversal' of the types of the /named/ fields of a constructor. conNamedFields :: Traversal' Con VarBangType conNamedFields _ c@NormalC{} = pure c conNamedFields _ c@InfixC{} = pure c conNamedFields f (RecC n fs) = RecC n <$> traverse f fs conNamedFields f (ForallC a b fs) = ForallC a b <$> conNamedFields f fs conNamedFields _ c@GadtC{} = pure c conNamedFields f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverse f argTys <*> pure retTy -- Lenses and Prisms locFileName :: Lens' Loc String locFileName = lens loc_filename $ \loc fn -> loc { loc_filename = fn } locPackage :: Lens' Loc String locPackage = lens loc_package $ \loc fn -> loc { loc_package = fn } locModule :: Lens' Loc String locModule = lens loc_module $ \loc fn -> loc { loc_module = fn } locStart :: Lens' Loc CharPos locStart = lens loc_start $ \loc fn -> loc { loc_start = fn } locEnd :: Lens' Loc CharPos locEnd = lens loc_end $ \loc fn -> loc { loc_end = fn } funDepInputs :: Lens' FunDep [Name] funDepInputs = lens g s where g (FunDep xs _) = xs s (FunDep _ ys) xs = FunDep xs ys funDepOutputs :: Lens' FunDep [Name] funDepOutputs = lens g s where g (FunDep _ xs) = xs s (FunDep ys _) = FunDep ys fieldExpName :: Lens' FieldExp Name fieldExpName = _1 fieldExpExpression :: Lens' FieldExp Exp fieldExpExpression = _2 fieldPatName :: Lens' FieldPat Name fieldPatName = _1 fieldPatPattern :: Lens' FieldPat Pat fieldPatPattern = _2 matchPattern :: Lens' Match Pat matchPattern = lens g s where g (Match p _ _) = p s (Match _ x y) p = Match p x y matchBody :: Lens' Match Body matchBody = lens g s where g (Match _ b _) = b s (Match x _ y) b = Match x b y matchDeclarations :: Lens' Match [Dec] matchDeclarations = lens g s where g (Match _ _ ds) = ds s (Match x y _ ) = Match x y fixityPrecedence :: Lens' Fixity Int fixityPrecedence = lens g s where g (Fixity i _) = i s (Fixity _ x) i = Fixity i x fixityDirection :: Lens' Fixity FixityDirection fixityDirection = lens g s where g (Fixity _ d) = d s (Fixity i _) = Fixity i clausePattern :: Lens' Clause [Pat] clausePattern = lens g s where g (Clause ps _ _) = ps s (Clause _ x y) ps = Clause ps x y clauseBody :: Lens' Clause Body clauseBody = lens g s where g (Clause _ b _) = b s (Clause x _ y) b = Clause x b y clauseDecs :: Lens' Clause [Dec] clauseDecs = lens g s where g (Clause _ _ ds) = ds s (Clause x y _ ) = Clause x y injectivityAnnOutput :: Lens' InjectivityAnn Name injectivityAnnOutput = lens g s where g (InjectivityAnn o _) = o s (InjectivityAnn _ i) o = InjectivityAnn o i injectivityAnnInputs :: Lens' InjectivityAnn [Name] injectivityAnnInputs = lens g s where g (InjectivityAnn _ i) = i s (InjectivityAnn o _) = InjectivityAnn o typeFamilyHeadName :: Lens' TypeFamilyHead Name typeFamilyHeadName = lens g s where g (TypeFamilyHead n _ _ _ ) = n s (TypeFamilyHead _ tvbs rs ia) n = TypeFamilyHead n tvbs rs ia typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndrVis] typeFamilyHeadTyVarBndrs = lens g s where g (TypeFamilyHead _ tvbs _ _ ) = tvbs s (TypeFamilyHead n _ rs ia) tvbs = TypeFamilyHead n tvbs rs ia typeFamilyHeadResultSig :: Lens' TypeFamilyHead FamilyResultSig typeFamilyHeadResultSig = lens g s where g (TypeFamilyHead _ _ rs _ ) = rs s (TypeFamilyHead n tvbs _ ia) rs = TypeFamilyHead n tvbs rs ia typeFamilyHeadInjectivityAnn :: Lens' TypeFamilyHead (Maybe InjectivityAnn) typeFamilyHeadInjectivityAnn = lens g s where g (TypeFamilyHead _ _ _ ia) = ia s (TypeFamilyHead n tvbs rs _ ) = TypeFamilyHead n tvbs rs bangSourceUnpackedness :: Lens' Bang SourceUnpackedness bangSourceUnpackedness = lens g s where g (Bang su _ ) = su s (Bang _ ss) su = Bang su ss bangSourceStrictness :: Lens' Bang SourceStrictness bangSourceStrictness = lens g s where g (Bang _ su) = su s (Bang ss _ ) = Bang ss #if MIN_VERSION_template_haskell(2,12,0) derivClauseStrategy :: Lens' DerivClause (Maybe DerivStrategy) derivClauseStrategy = lens g s where g (DerivClause mds _) = mds s (DerivClause _ c) mds = DerivClause mds c derivClauseCxt :: Lens' DerivClause Cxt derivClauseCxt = lens g s where g (DerivClause _ c) = c s (DerivClause mds _) = DerivClause mds #endif _ClassI :: Prism' Info (Dec, [InstanceDec]) _ClassI = prism' reviewer remitter where reviewer (x, y) = ClassI x y remitter (ClassI x y) = Just (x, y) remitter _ = Nothing _ClassOpI :: Prism' Info (Name, Type, ParentName) _ClassOpI = prism' reviewer remitter where reviewer (x, y, z) = ClassOpI x y z remitter (ClassOpI x y z) = Just (x, y, z) remitter _ = Nothing _TyConI :: Prism' Info Dec _TyConI = prism' reviewer remitter where reviewer = TyConI remitter (TyConI x) = Just x remitter _ = Nothing _FamilyI :: Prism' Info (Dec, [InstanceDec]) _FamilyI = prism' reviewer remitter where reviewer (x, y) = FamilyI x y remitter (FamilyI x y) = Just (x, y) remitter _ = Nothing _PrimTyConI :: Prism' Info (Name, Arity, Unlifted) _PrimTyConI = prism' reviewer remitter where reviewer (x, y, z) = PrimTyConI x y z remitter (PrimTyConI x y z) = Just (x, y, z) remitter _ = Nothing _DataConI :: Prism' Info (Name, Type, ParentName) _DataConI = prism' reviewer remitter where reviewer (x, y, z) = DataConI x y z remitter (DataConI x y z) = Just (x, y, z) remitter _ = Nothing _VarI :: Prism' Info (Name, Type, Maybe Dec) _VarI = prism' reviewer remitter where reviewer (x, y, z) = VarI x y z remitter (VarI x y z) = Just (x, y, z) remitter _ = Nothing _TyVarI :: Prism' Info (Name, Type) _TyVarI = prism' reviewer remitter where reviewer (x, y) = TyVarI x y remitter (TyVarI x y) = Just (x, y) remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _PatSynI :: Prism' Info (Name, PatSynType) _PatSynI = prism' reviewer remitter where reviewer (x, y) = PatSynI x y remitter (PatSynI x y) = Just (x, y) remitter _ = Nothing #endif _FunD :: Prism' Dec (Name, [Clause]) _FunD = prism' reviewer remitter where reviewer (x, y) = FunD x y remitter (FunD x y) = Just (x,y) remitter _ = Nothing _ValD :: Prism' Dec (Pat, Body, [Dec]) _ValD = prism' reviewer remitter where reviewer (x, y, z) = ValD x y z remitter (ValD x y z) = Just (x, y, z) remitter _ = Nothing _TySynD :: Prism' Dec (Name, [TyVarBndrVis], Type) _TySynD = prism' reviewer remitter where reviewer (x, y, z) = TySynD x y z remitter (TySynD x y z) = Just (x, y, z) remitter _ = Nothing _ClassD :: Prism' Dec (Cxt, Name, [TyVarBndrVis], [FunDep], [Dec]) _ClassD = prism' reviewer remitter where reviewer (x, y, z, w, u) = ClassD x y z w u remitter (ClassD x y z w u) = Just (x, y, z, w, u) remitter _ = Nothing _InstanceD :: Prism' Dec (Maybe Overlap, Cxt, Type, [Dec]) _InstanceD = prism' reviewer remitter where reviewer (x, y, z, w) = InstanceD x y z w remitter (InstanceD x y z w) = Just (x, y, z, w) remitter _ = Nothing _Overlappable :: Prism' Overlap () _Overlappable = prism' reviewer remitter where reviewer () = Overlappable remitter Overlappable = Just () remitter _ = Nothing _Overlapping :: Prism' Overlap () _Overlapping = prism' reviewer remitter where reviewer () = Overlapping remitter Overlapping = Just () remitter _ = Nothing _Overlaps :: Prism' Overlap () _Overlaps = prism' reviewer remitter where reviewer () = Overlaps remitter Overlaps = Just () remitter _ = Nothing _Incoherent :: Prism' Overlap () _Incoherent = prism' reviewer remitter where reviewer () = Incoherent remitter Incoherent = Just () remitter _ = Nothing _SigD :: Prism' Dec (Name, Type) _SigD = prism' reviewer remitter where reviewer (x, y) = SigD x y remitter (SigD x y) = Just (x, y) remitter _ = Nothing _ForeignD :: Prism' Dec Foreign _ForeignD = prism' reviewer remitter where reviewer = ForeignD remitter (ForeignD x) = Just x remitter _ = Nothing _InfixD :: Prism' Dec (Fixity, Name) _InfixD = prism' reviewer remitter where reviewer (x, y) = InfixD x y remitter (InfixD x y) = Just (x, y) remitter _ = Nothing _PragmaD :: Prism' Dec Pragma _PragmaD = prism' reviewer remitter where reviewer = PragmaD remitter (PragmaD x) = Just x remitter _ = Nothing -- | -- @ -- _TySynInstD :: 'Prism'' 'Dec' 'TySynEqn' -- template-haskell-2.15+ -- _TySynInstD :: 'Prism'' 'Dec' ('Name', 'TySynEqn') -- template-haskell-2.9 through 2.14 -- _TySynInstD :: 'Prism'' 'Dec' ('Name', ['Type'], 'Type') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0) _TySynInstD :: Prism' Dec TySynEqn _TySynInstD = prism' reviewer remitter where reviewer = TySynInstD remitter (TySynInstD x) = Just x remitter _ = Nothing #else _TySynInstD :: Prism' Dec (Name, TySynEqn) _TySynInstD = prism' reviewer remitter where reviewer (x, y) = TySynInstD x y remitter (TySynInstD x y) = Just (x, y) remitter _ = Nothing #endif _RoleAnnotD :: Prism' Dec (Name, [Role]) _RoleAnnotD = prism' reviewer remitter where reviewer (x, y) = RoleAnnotD x y remitter (RoleAnnotD x y) = Just (x, y) remitter _ = Nothing -- | -- @ -- _StandaloneDerivD :: 'Prism'' 'Dec' ('Maybe' 'DerivStrategy', 'Cxt', 'Type') -- template-haskell-2.12+ -- _StandaloneDerivD :: 'Prism'' 'Dec' ('Cxt', 'Type') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,12,0) _StandaloneDerivD :: Prism' Dec (Maybe DerivStrategy, Cxt, Type) _StandaloneDerivD = prism' reviewer remitter where reviewer (x, y, z) = StandaloneDerivD x y z remitter (StandaloneDerivD x y z) = Just (x, y, z) remitter _ = Nothing #else _StandaloneDerivD :: Prism' Dec (Cxt, Type) _StandaloneDerivD = prism' reviewer remitter where reviewer (x, y) = StandaloneDerivD x y remitter (StandaloneDerivD x y) = Just (x, y) remitter _ = Nothing #endif _DefaultSigD :: Prism' Dec (Name, Type) _DefaultSigD = prism' reviewer remitter where reviewer (x, y) = DefaultSigD x y remitter (DefaultSigD x y) = Just (x, y) remitter _ = Nothing # if MIN_VERSION_template_haskell(2,12,0) type DataPrism' tys cons = Prism' Dec (Cxt, Name, tys, Maybe Kind, cons, [DerivClause]) # else type DataPrism' tys cons = Prism' Dec (Cxt, Name, tys, Maybe Kind, cons, Cxt) # endif -- | -- @ -- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndrUnit'], 'Type', 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.15+ -- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12 through 2.14 -- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0) _DataInstD :: Prism' Dec (Cxt, Maybe [TyVarBndrUnit], Type, Maybe Kind, [Con], [DerivClause]) _DataInstD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = DataInstD x y z w u v remitter (DataInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else _DataInstD :: DataPrism' [Type] [Con] _DataInstD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = DataInstD x y z w u v remitter (DataInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #endif -- | -- @ -- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndrUnit'], 'Type', 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.15+ -- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12 through 2.14 -- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0) _NewtypeInstD :: Prism' Dec (Cxt, Maybe [TyVarBndrUnit], Type, Maybe Kind, Con, [DerivClause]) _NewtypeInstD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = NewtypeInstD x y z w u v remitter (NewtypeInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else _NewtypeInstD :: DataPrism' [Type] Con _NewtypeInstD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = NewtypeInstD x y z w u v remitter (NewtypeInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #endif _ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn]) _ClosedTypeFamilyD = prism' reviewer remitter where reviewer (x, y) = ClosedTypeFamilyD x y remitter (ClosedTypeFamilyD x y) = Just (x, y) remitter _ = Nothing -- | -- @ -- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12+ -- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- Earlier versions -- @ _DataD :: DataPrism' [TyVarBndrVis] [Con] _DataD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = DataD x y z w u v remitter (DataD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -- | -- @ -- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12+ -- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- Earlier versions -- @ _NewtypeD :: DataPrism' [TyVarBndrVis] Con _NewtypeD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = NewtypeD x y z w u v remitter (NewtypeD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing _DataFamilyD :: Prism' Dec (Name, [TyVarBndrVis], Maybe Kind) _DataFamilyD = prism' reviewer remitter where reviewer (x, y, z) = DataFamilyD x y z remitter (DataFamilyD x y z) = Just (x, y, z) remitter _ = Nothing _OpenTypeFamilyD :: Prism' Dec TypeFamilyHead _OpenTypeFamilyD = prism' reviewer remitter where reviewer = OpenTypeFamilyD remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _PatSynD :: Prism' Dec (Name, PatSynArgs, PatSynDir, Pat) _PatSynD = prism' reviewer remitter where reviewer (x, y, z, w) = PatSynD x y z w remitter (PatSynD x y z w) = Just (x, y, z, w) remitter _ = Nothing _PatSynSigD :: Prism' Dec (Name, PatSynType) _PatSynSigD = prism' reviewer remitter where reviewer (x, y) = PatSynSigD x y remitter (PatSynSigD x y) = Just (x, y) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,15,0) _ImplicitParamBindD :: Prism' Dec (String, Exp) _ImplicitParamBindD = prism' reviewer remitter where reviewer (x, y) = ImplicitParamBindD x y remitter (ImplicitParamBindD x y) = Just (x, y) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,19,0) _DefaultD :: Prism' Dec [Type] _DefaultD = prism' reviewer remitter where reviewer = DefaultD remitter (DefaultD x) = Just x remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,20,0) _TypeDataD :: Prism' Dec (Name, [TyVarBndrVis], Maybe Kind, [Con]) _TypeDataD = prism' reviewer remitter where reviewer (x, y, z, u) = TypeDataD x y z u remitter (TypeDataD x y z u) = Just (x, y, z, u) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,12,0) _Unidir :: Prism' PatSynDir () _Unidir = prism' reviewer remitter where reviewer () = Unidir remitter Unidir = Just () remitter _ = Nothing _ImplBidir :: Prism' PatSynDir () _ImplBidir = prism' reviewer remitter where reviewer () = ImplBidir remitter ImplBidir = Just () remitter _ = Nothing _ExplBidir :: Prism' PatSynDir [Clause] _ExplBidir = prism' reviewer remitter where reviewer = ExplBidir remitter (ExplBidir x) = Just x remitter _ = Nothing _PrefixPatSyn :: Prism' PatSynArgs [Name] _PrefixPatSyn = prism' reviewer remitter where reviewer = PrefixPatSyn remitter (PrefixPatSyn x) = Just x remitter _ = Nothing _InfixPatSyn :: Prism' PatSynArgs (Name, Name) _InfixPatSyn = prism' reviewer remitter where reviewer (x, y) = InfixPatSyn x y remitter (InfixPatSyn x y) = Just (x, y) remitter _ = Nothing _RecordPatSyn :: Prism' PatSynArgs [Name] _RecordPatSyn = prism' reviewer remitter where reviewer = RecordPatSyn remitter (RecordPatSyn x) = Just x remitter _ = Nothing #endif _NormalC :: Prism' Con (Name, [BangType]) _NormalC = prism' reviewer remitter where reviewer (x, y) = NormalC x y remitter (NormalC x y) = Just (x, y) remitter _ = Nothing _RecC :: Prism' Con (Name, [VarBangType]) _RecC = prism' reviewer remitter where reviewer (x, y) = RecC x y remitter (RecC x y) = Just (x, y) remitter _ = Nothing _InfixC :: Prism' Con (BangType, Name, BangType ) _InfixC = prism' reviewer remitter where reviewer (x, y, z) = InfixC x y z remitter (InfixC x y z) = Just (x, y, z) remitter _ = Nothing _ForallC :: Prism' Con ([TyVarBndrSpec], Cxt, Con) _ForallC = prism' reviewer remitter where reviewer (x, y, z) = ForallC x y z remitter (ForallC x y z) = Just (x, y, z) remitter _ = Nothing _GadtC :: Prism' Con ([Name], [BangType], Type) _GadtC = prism' reviewer remitter where reviewer (x, y, z) = GadtC x y z remitter (GadtC x y z) = Just (x, y, z) remitter _ = Nothing _RecGadtC :: Prism' Con ([Name], [VarBangType], Type) _RecGadtC = prism' reviewer remitter where reviewer (x, y, z) = RecGadtC x y z remitter (RecGadtC x y z) = Just (x, y, z) remitter _ = Nothing _NoSourceUnpackedness :: Prism' SourceUnpackedness () _NoSourceUnpackedness = prism' reviewer remitter where reviewer () = NoSourceUnpackedness remitter NoSourceUnpackedness = Just () remitter _ = Nothing _SourceNoUnpack :: Prism' SourceUnpackedness () _SourceNoUnpack = prism' reviewer remitter where reviewer () = SourceNoUnpack remitter SourceNoUnpack = Just () remitter _ = Nothing _SourceUnpack :: Prism' SourceUnpackedness () _SourceUnpack = prism' reviewer remitter where reviewer () = SourceUnpack remitter SourceUnpack = Just () remitter _ = Nothing _NoSourceStrictness :: Prism' SourceStrictness () _NoSourceStrictness = prism' reviewer remitter where reviewer () = NoSourceStrictness remitter NoSourceStrictness = Just () remitter _ = Nothing _SourceLazy :: Prism' SourceStrictness () _SourceLazy = prism' reviewer remitter where reviewer () = SourceLazy remitter SourceLazy = Just () remitter _ = Nothing _SourceStrict :: Prism' SourceStrictness () _SourceStrict = prism' reviewer remitter where reviewer () = SourceStrict remitter SourceStrict = Just () remitter _ = Nothing _DecidedLazy :: Prism' DecidedStrictness () _DecidedLazy = prism' reviewer remitter where reviewer () = DecidedLazy remitter DecidedLazy = Just () remitter _ = Nothing _DecidedStrict :: Prism' DecidedStrictness () _DecidedStrict = prism' reviewer remitter where reviewer () = DecidedStrict remitter DecidedStrict = Just () remitter _ = Nothing _DecidedUnpack :: Prism' DecidedStrictness () _DecidedUnpack = prism' reviewer remitter where reviewer () = DecidedUnpack remitter DecidedUnpack = Just () remitter _ = Nothing _ImportF :: Prism' Foreign (Callconv, Safety, String, Name, Type) _ImportF = prism' reviewer remitter where reviewer (x, y, z, w, u) = ImportF x y z w u remitter (ImportF x y z w u) = Just (x,y,z,w,u) remitter _ = Nothing _ExportF :: Prism' Foreign (Callconv, String, Name, Type) _ExportF = prism' reviewer remitter where reviewer (x, y, z, w) = ExportF x y z w remitter (ExportF x y z w) = Just (x, y, z, w) remitter _ = Nothing _CCall :: Prism' Callconv () _CCall = prism' reviewer remitter where reviewer () = CCall remitter CCall = Just () remitter _ = Nothing _StdCall :: Prism' Callconv () _StdCall = prism' reviewer remitter where reviewer () = StdCall remitter StdCall = Just () remitter _ = Nothing _CApi :: Prism' Callconv () _CApi = prism' reviewer remitter where reviewer () = CApi remitter CApi = Just () remitter _ = Nothing _Prim :: Prism' Callconv () _Prim = prism' reviewer remitter where reviewer () = Prim remitter Prim = Just () remitter _ = Nothing _JavaScript :: Prism' Callconv () _JavaScript = prism' reviewer remitter where reviewer () = JavaScript remitter JavaScript = Just () remitter _ = Nothing _Unsafe :: Prism' Safety () _Unsafe = prism' reviewer remitter where reviewer () = Unsafe remitter Unsafe = Just () remitter _ = Nothing _Safe :: Prism' Safety () _Safe = prism' reviewer remitter where reviewer () = Safe remitter Safe = Just () remitter _ = Nothing _Interruptible :: Prism' Safety () _Interruptible = prism' reviewer remitter where reviewer () = Interruptible remitter Interruptible = Just () remitter _ = Nothing _InlineP :: Prism' Pragma (Name, Inline, RuleMatch, Phases) _InlineP = prism' reviewer remitter where reviewer (x, y, z, w) = InlineP x y z w remitter (InlineP x y z w) = Just (x, y, z, w) remitter _ = Nothing _SpecialiseP :: Prism' Pragma (Name, Type, Maybe Inline, Phases) _SpecialiseP = prism' reviewer remitter where reviewer (x, y, z, w) = SpecialiseP x y z w remitter (SpecialiseP x y z w) = Just (x, y, z, w) remitter _ = Nothing -- TODO add lenses for InlineSpec _SpecialiseInstP :: Prism' Pragma Type _SpecialiseInstP = prism' reviewer remitter where reviewer = SpecialiseInstP remitter (SpecialiseInstP x) = Just x remitter _ = Nothing -- | -- @ -- _RuleP :: 'Prism'' 'Pragma' ('String', 'Maybe' ['TyVarBndrUnit'], ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- template-haskell-2.15+ -- _RuleP :: 'Prism'' 'Pragma' ('String', ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0) _RuleP :: Prism' Pragma (String, Maybe [TyVarBndrUnit], [RuleBndr], Exp, Exp, Phases) _RuleP = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = RuleP x y z w u v remitter (RuleP x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else _RuleP :: Prism' Pragma (String, [RuleBndr], Exp, Exp, Phases) _RuleP = prism' reviewer remitter where reviewer (x, y, z, w, u) = RuleP x y z w u remitter (RuleP x y z w u) = Just (x, y, z, w, u) remitter _ = Nothing #endif _AnnP :: Prism' Pragma (AnnTarget, Exp) _AnnP = prism' reviewer remitter where reviewer (x, y) = AnnP x y remitter (AnnP x y) = Just (x, y) remitter _ = Nothing _LineP :: Prism' Pragma (Int, String) _LineP = prism' reviewer remitter where reviewer (x, y) = LineP x y remitter (LineP x y) = Just (x, y) remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _CompleteP :: Prism' Pragma ([Name], Maybe Name) _CompleteP = prism' reviewer remitter where reviewer (x, y) = CompleteP x y remitter (CompleteP x y) = Just (x, y) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,19,0) _OpaqueP :: Prism' Pragma Name _OpaqueP = prism' reviewer remitter where reviewer = OpaqueP remitter (OpaqueP x) = Just x remitter _ = Nothing #endif _NoInline :: Prism' Inline () _NoInline = prism' reviewer remitter where reviewer () = NoInline remitter NoInline = Just () remitter _ = Nothing _Inline :: Prism' Inline () _Inline = prism' reviewer remitter where reviewer () = Inline remitter Inline = Just () remitter _ = Nothing _Inlinable :: Prism' Inline () _Inlinable = prism' reviewer remitter where reviewer () = Inlinable remitter Inlinable = Just () remitter _ = Nothing _ConLike :: Prism' RuleMatch () _ConLike = prism' reviewer remitter where reviewer () = ConLike remitter ConLike = Just () remitter _ = Nothing _FunLike :: Prism' RuleMatch () _FunLike = prism' reviewer remitter where reviewer () = FunLike remitter FunLike = Just () remitter _ = Nothing _AllPhases :: Prism' Phases () _AllPhases = prism' reviewer remitter where reviewer () = AllPhases remitter AllPhases = Just () remitter _ = Nothing _FromPhase :: Prism' Phases Int _FromPhase = prism' reviewer remitter where reviewer = FromPhase remitter (FromPhase x) = Just x remitter _ = Nothing _BeforePhase :: Prism' Phases Int _BeforePhase = prism' reviewer remitter where reviewer = BeforePhase remitter (BeforePhase x) = Just x remitter _ = Nothing _RuleVar :: Prism' RuleBndr Name _RuleVar = prism' reviewer remitter where reviewer = RuleVar remitter (RuleVar x) = Just x remitter _ = Nothing _TypedRuleVar :: Prism' RuleBndr (Name, Type) _TypedRuleVar = prism' reviewer remitter where reviewer (x, y) = TypedRuleVar x y remitter (TypedRuleVar x y) = Just (x, y) remitter _ = Nothing _ModuleAnnotation :: Prism' AnnTarget () _ModuleAnnotation = prism' reviewer remitter where reviewer () = ModuleAnnotation remitter ModuleAnnotation = Just () remitter _ = Nothing _TypeAnnotation :: Prism' AnnTarget Name _TypeAnnotation = prism' reviewer remitter where reviewer = TypeAnnotation remitter (TypeAnnotation x) = Just x remitter _ = Nothing _ValueAnnotation :: Prism' AnnTarget Name _ValueAnnotation = prism' reviewer remitter where reviewer = ValueAnnotation remitter (ValueAnnotation x) = Just x remitter _ = Nothing _FunDep :: Iso' FunDep ([Name], [Name]) _FunDep = iso remitter reviewer where reviewer (x, y) = FunDep x y remitter (FunDep x y) = (x, y) #if !(MIN_VERSION_template_haskell(2,13,0)) _TypeFam :: Prism' FamFlavour () _TypeFam = prism' reviewer remitter where reviewer () = TypeFam remitter TypeFam = Just () remitter _ = Nothing _DataFam :: Prism' FamFlavour () _DataFam = prism' reviewer remitter where reviewer () = DataFam remitter DataFam = Just () remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,15,0) tySynEqnLHS :: Lens' TySynEqn Type tySynEqnLHS = lens g s where g (TySynEqn _ lhs _) = lhs s (TySynEqn mtvbs _ rhs) lhs = TySynEqn mtvbs lhs rhs tySynEqnPatterns :: Lens' TySynEqn [Type] tySynEqnPatterns = lens g s where g (TySynEqn _ lhs _) = pats where (_n, pats) = unfoldType lhs s (TySynEqn mtvbs lhs rhs) pats = TySynEqn mtvbs (F.foldl' AppT n pats) rhs where (n, _pats) = unfoldType lhs tySynEqnResult :: Lens' TySynEqn Type tySynEqnResult = lens g s where g (TySynEqn _ _ rhs) = rhs s (TySynEqn mtvbs lhs _) = TySynEqn mtvbs lhs #else tySynEqnPatterns :: Lens' TySynEqn [Type] tySynEqnPatterns = lens g s where g (TySynEqn xs _) = xs s (TySynEqn _ y) xs = TySynEqn xs y tySynEqnResult :: Lens' TySynEqn Type tySynEqnResult = lens g s where g (TySynEqn _ x) = x s (TySynEqn xs _) = TySynEqn xs #endif _InfixL :: Prism' FixityDirection () _InfixL = prism' reviewer remitter where reviewer () = InfixL remitter InfixL = Just () remitter _ = Nothing _InfixR :: Prism' FixityDirection () _InfixR = prism' reviewer remitter where reviewer () = InfixR remitter InfixR = Just () remitter _ = Nothing _InfixN :: Prism' FixityDirection () _InfixN = prism' reviewer remitter where reviewer () = InfixN remitter InfixN = Just () remitter _ = Nothing _VarE :: Prism' Exp Name _VarE = prism' reviewer remitter where reviewer = VarE remitter (VarE x) = Just x remitter _ = Nothing _ConE :: Prism' Exp Name _ConE = prism' reviewer remitter where reviewer = ConE remitter (ConE x) = Just x remitter _ = Nothing _LitE :: Prism' Exp Lit _LitE = prism' reviewer remitter where reviewer = LitE remitter (LitE x) = Just x remitter _ = Nothing _AppE :: Prism' Exp (Exp, Exp) _AppE = prism' reviewer remitter where reviewer (x, y) = AppE x y remitter (AppE x y) = Just (x, y) remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _AppTypeE :: Prism' Exp (Exp, Type) _AppTypeE = prism' reviewer remitter where reviewer (x, y) = AppTypeE x y remitter (AppTypeE x y) = Just (x, y) remitter _ = Nothing #endif _InfixE :: Prism' Exp (Maybe Exp, Exp, Maybe Exp) _InfixE = prism' reviewer remitter where reviewer (x, y, z) = InfixE x y z remitter (InfixE x y z) = Just (x, y, z) remitter _ = Nothing _UInfixE :: Prism' Exp (Exp, Exp, Exp) _UInfixE = prism' reviewer remitter where reviewer (x, y, z) = UInfixE x y z remitter (UInfixE x y z) = Just (x, y, z) remitter _ = Nothing _ParensE :: Prism' Exp Exp _ParensE = prism' reviewer remitter where reviewer = ParensE remitter (ParensE x) = Just x remitter _ = Nothing _LamE :: Prism' Exp ([Pat], Exp) _LamE = prism' reviewer remitter where reviewer (x, y) = LamE x y remitter (LamE x y) = Just (x, y) remitter _ = Nothing _LamCaseE :: Prism' Exp [Match] _LamCaseE = prism' reviewer remitter where reviewer = LamCaseE remitter (LamCaseE x) = Just x remitter _ = Nothing -- | -- @ -- _TupE :: 'Prism'' 'Exp' ['Maybe' 'Exp'] -- template-haskell-2.16+ -- _TupE :: 'Prism'' 'Exp' ['Exp'] -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,16,0) _TupE :: Prism' Exp [Maybe Exp] #else _TupE :: Prism' Exp [Exp] #endif _TupE = prism' reviewer remitter where reviewer = TupE remitter (TupE x) = Just x remitter _ = Nothing -- | -- @ -- _UnboxedTupE :: 'Prism'' 'Exp' ['Maybe' 'Exp'] -- template-haskell-2.16+ -- _UnboxedTupE :: 'Prism'' 'Exp' ['Exp'] -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,16,0) _UnboxedTupE :: Prism' Exp [Maybe Exp] #else _UnboxedTupE :: Prism' Exp [Exp] #endif _UnboxedTupE = prism' reviewer remitter where reviewer = UnboxedTupE remitter (UnboxedTupE x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _UnboxedSumE :: Prism' Exp (Exp, SumAlt, SumArity) _UnboxedSumE = prism' reviewer remitter where reviewer (x, y, z) = UnboxedSumE x y z remitter (UnboxedSumE x y z) = Just (x, y, z) remitter _ = Nothing #endif _CondE :: Prism' Exp (Exp, Exp, Exp) _CondE = prism' reviewer remitter where reviewer (x, y, z) = CondE x y z remitter (CondE x y z) = Just (x, y, z) remitter _ = Nothing _MultiIfE :: Prism' Exp [(Guard, Exp)] _MultiIfE = prism' reviewer remitter where reviewer = MultiIfE remitter (MultiIfE x) = Just x remitter _ = Nothing _LetE :: Prism' Exp ([Dec], Exp) _LetE = prism' reviewer remitter where reviewer (x, y) = LetE x y remitter (LetE x y) = Just (x, y) remitter _ = Nothing _CaseE :: Prism' Exp (Exp, [Match]) _CaseE = prism' reviewer remitter where reviewer (x, y) = CaseE x y remitter (CaseE x y) = Just (x, y) remitter _ = Nothing -- | -- @ -- _DoE :: 'Prism'' 'Exp' ('Maybe' 'ModName', ['Stmt']) -- template-haskell-2.17+ -- _DoE :: 'Prism'' 'Exp' ['Stmt'] -- Earlier versions -- @ # if MIN_VERSION_template_haskell(2,17,0) _DoE :: Prism' Exp (Maybe ModName, [Stmt]) _DoE = prism' reviewer remitter where reviewer (x, y) = DoE x y remitter (DoE x y) = Just (x, y) remitter _ = Nothing # else _DoE :: Prism' Exp [Stmt] _DoE = prism' reviewer remitter where reviewer = DoE remitter (DoE x) = Just x remitter _ = Nothing # endif _CompE :: Prism' Exp [Stmt] _CompE = prism' reviewer remitter where reviewer = CompE remitter (CompE x) = Just x remitter _ = Nothing _ArithSeqE :: Prism' Exp Range _ArithSeqE = prism' reviewer remitter where reviewer = ArithSeqE remitter (ArithSeqE x) = Just x remitter _ = Nothing _ListE :: Prism' Exp [Exp] _ListE = prism' reviewer remitter where reviewer = ListE remitter (ListE x) = Just x remitter _ = Nothing _SigE :: Prism' Exp (Exp, Type) _SigE = prism' reviewer remitter where reviewer (x, y) = SigE x y remitter (SigE x y) = Just (x, y) remitter _ = Nothing _RecConE :: Prism' Exp (Name, [FieldExp]) _RecConE = prism' reviewer remitter where reviewer (x, y) = RecConE x y remitter (RecConE x y) = Just (x, y) remitter _ = Nothing _RecUpdE :: Prism' Exp (Exp, [FieldExp]) _RecUpdE = prism' reviewer remitter where reviewer (x, y) = RecUpdE x y remitter (RecUpdE x y) = Just (x, y) remitter _ = Nothing _StaticE :: Prism' Exp Exp _StaticE = prism' reviewer remitter where reviewer = StaticE remitter (StaticE x) = Just x remitter _ = Nothing _UnboundVarE :: Prism' Exp Name _UnboundVarE = prism' reviewer remitter where reviewer = UnboundVarE remitter (UnboundVarE x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,13,0) _LabelE :: Prism' Exp String _LabelE = prism' reviewer remitter where reviewer = LabelE remitter (LabelE x) = Just x remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,15,0) -- | -- @ -- _MDoE :: 'Prism'' 'Exp' ('Maybe' 'ModName', ['Stmt']) -- template-haskell-2.17+ -- _MDoE :: 'Prism'' 'Exp' ['Stmt'] -- Earlier versions -- @ # if MIN_VERSION_template_haskell(2,17,0) _MDoE :: Prism' Exp (Maybe ModName, [Stmt]) _MDoE = prism' reviewer remitter where reviewer (x, y) = MDoE x y remitter (MDoE x y) = Just (x, y) remitter _ = Nothing # else _MDoE :: Prism' Exp [Stmt] _MDoE = prism' reviewer remitter where reviewer = MDoE remitter (MDoE x) = Just x remitter _ = Nothing # endif _ImplicitParamVarE :: Prism' Exp String _ImplicitParamVarE = prism' reviewer remitter where reviewer = ImplicitParamVarE remitter (ImplicitParamVarE x) = Just x remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,18,0) _GetFieldE :: Prism' Exp (Exp, String) _GetFieldE = prism' reviewer remitter where reviewer (x, y) = GetFieldE x y remitter (GetFieldE x y) = Just (x, y) remitter _ = Nothing _ProjectionE :: Prism' Exp (NonEmpty String) _ProjectionE = prism' reviewer remitter where reviewer = ProjectionE remitter (ProjectionE x) = Just x remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,19,0) _LamCasesE :: Prism' Exp [Clause] _LamCasesE = prism' reviewer remitter where reviewer = LamCasesE remitter (LamCasesE x) = Just x remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,21,0) _TypedBracketE :: Prism' Exp Exp _TypedBracketE = prism' reviewer remitter where reviewer = TypedBracketE remitter (TypedBracketE x) = Just x remitter _ = Nothing _TypedSpliceE :: Prism' Exp Exp _TypedSpliceE = prism' reviewer remitter where reviewer = TypedSpliceE remitter (TypedSpliceE x) = Just x remitter _ = Nothing #endif _GuardedB :: Prism' Body [(Guard, Exp)] _GuardedB = prism' reviewer remitter where reviewer = GuardedB remitter (GuardedB x) = Just x remitter _ = Nothing _NormalB :: Prism' Body Exp _NormalB = prism' reviewer remitter where reviewer = NormalB remitter (NormalB x) = Just x remitter _ = Nothing _NormalG :: Prism' Guard Exp _NormalG = prism' reviewer remitter where reviewer = NormalG remitter (NormalG x) = Just x remitter _ = Nothing _PatG :: Prism' Guard [Stmt] _PatG = prism' reviewer remitter where reviewer = PatG remitter (PatG x) = Just x remitter _ = Nothing _BindS :: Prism' Stmt (Pat, Exp) _BindS = prism' reviewer remitter where reviewer (x, y) = BindS x y remitter (BindS x y) = Just (x, y) remitter _ = Nothing _LetS :: Prism' Stmt [Dec] _LetS = prism' reviewer remitter where reviewer = LetS remitter (LetS x) = Just x remitter _ = Nothing _NoBindS :: Prism' Stmt Exp _NoBindS = prism' reviewer remitter where reviewer = NoBindS remitter (NoBindS x) = Just x remitter _ = Nothing _ParS :: Prism' Stmt [[Stmt]] _ParS = prism' reviewer remitter where reviewer = ParS remitter (ParS x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,15,0) _RecS :: Prism' Stmt [Stmt] _RecS = prism' reviewer remitter where reviewer = RecS remitter (RecS x) = Just x remitter _ = Nothing #endif _FromR :: Prism' Range Exp _FromR = prism' reviewer remitter where reviewer = FromR remitter (FromR x) = Just x remitter _ = Nothing _FromThenR :: Prism' Range (Exp, Exp) _FromThenR = prism' reviewer remitter where reviewer (x, y) = FromThenR x y remitter (FromThenR x y) = Just (x, y) remitter _ = Nothing _FromToR :: Prism' Range (Exp, Exp) _FromToR = prism' reviewer remitter where reviewer (x, y) = FromToR x y remitter (FromToR x y) = Just (x, y) remitter _ = Nothing _FromThenToR :: Prism' Range (Exp, Exp, Exp) _FromThenToR = prism' reviewer remitter where reviewer (x, y, z) = FromThenToR x y z remitter (FromThenToR x y z) = Just (x, y, z) remitter _ = Nothing _CharL :: Prism' Lit Char _CharL = prism' reviewer remitter where reviewer = CharL remitter (CharL x) = Just x remitter _ = Nothing _StringL :: Prism' Lit String _StringL = prism' reviewer remitter where reviewer = StringL remitter (StringL x) = Just x remitter _ = Nothing _IntegerL :: Prism' Lit Integer _IntegerL = prism' reviewer remitter where reviewer = IntegerL remitter (IntegerL x) = Just x remitter _ = Nothing _RationalL :: Prism' Lit Rational _RationalL = prism' reviewer remitter where reviewer = RationalL remitter (RationalL x) = Just x remitter _ = Nothing _IntPrimL :: Prism' Lit Integer _IntPrimL = prism' reviewer remitter where reviewer = IntPrimL remitter (IntPrimL x) = Just x remitter _ = Nothing _WordPrimL :: Prism' Lit Integer _WordPrimL = prism' reviewer remitter where reviewer = WordPrimL remitter (WordPrimL x) = Just x remitter _ = Nothing _FloatPrimL :: Prism' Lit Rational _FloatPrimL = prism' reviewer remitter where reviewer = FloatPrimL remitter (FloatPrimL x) = Just x remitter _ = Nothing _DoublePrimL :: Prism' Lit Rational _DoublePrimL = prism' reviewer remitter where reviewer = DoublePrimL remitter (DoublePrimL x) = Just x remitter _ = Nothing _StringPrimL :: Prism' Lit [Word8] _StringPrimL = prism' reviewer remitter where reviewer = StringPrimL remitter (StringPrimL x) = Just x remitter _ = Nothing _CharPrimL :: Prism' Lit Char _CharPrimL = prism' reviewer remitter where reviewer = CharPrimL remitter (CharPrimL x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,16,0) _BytesPrimL :: Prism' Lit Bytes _BytesPrimL = prism' reviewer remitter where reviewer = BytesPrimL remitter (BytesPrimL x) = Just x remitter _ = Nothing #endif _LitP :: Prism' Pat Lit _LitP = prism' reviewer remitter where reviewer = LitP remitter (LitP x) = Just x remitter _ = Nothing _VarP :: Prism' Pat Name _VarP = prism' reviewer remitter where reviewer = VarP remitter (VarP x) = Just x remitter _ = Nothing _TupP :: Prism' Pat [Pat] _TupP = prism' reviewer remitter where reviewer = TupP remitter (TupP x) = Just x remitter _ = Nothing _UnboxedTupP :: Prism' Pat [Pat] _UnboxedTupP = prism' reviewer remitter where reviewer = UnboxedTupP remitter (UnboxedTupP x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _UnboxedSumP :: Prism' Pat (Pat, SumAlt, SumArity) _UnboxedSumP = prism' reviewer remitter where reviewer (x, y, z) = UnboxedSumP x y z remitter (UnboxedSumP x y z) = Just (x, y, z) remitter _ = Nothing #endif -- | -- @ -- _ConP :: 'Prism'' 'Pat' ('Name', ['Type'], ['Pat']) -- template-haskell-2.18+ -- _ConP :: 'Prism'' 'Pat' ('Name', ['Pat']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,18,0) _ConP :: Prism' Pat (Name, [Type], [Pat]) _ConP = prism' reviewer remitter where reviewer (x, y, z) = ConP x y z remitter (ConP x y z) = Just (x, y, z) remitter _ = Nothing #else _ConP :: Prism' Pat (Name, [Pat]) _ConP = prism' reviewer remitter where reviewer (x, y) = ConP x y remitter (ConP x y) = Just (x, y) remitter _ = Nothing #endif _InfixP :: Prism' Pat (Pat, Name, Pat) _InfixP = prism' reviewer remitter where reviewer (x, y, z) = InfixP x y z remitter (InfixP x y z) = Just (x, y, z) remitter _ = Nothing _UInfixP :: Prism' Pat (Pat, Name, Pat) _UInfixP = prism' reviewer remitter where reviewer (x, y, z) = UInfixP x y z remitter (UInfixP x y z) = Just (x, y, z) remitter _ = Nothing _ParensP :: Prism' Pat Pat _ParensP = prism' reviewer remitter where reviewer = ParensP remitter (ParensP x) = Just x remitter _ = Nothing _TildeP :: Prism' Pat Pat _TildeP = prism' reviewer remitter where reviewer = TildeP remitter (TildeP x) = Just x remitter _ = Nothing _BangP :: Prism' Pat Pat _BangP = prism' reviewer remitter where reviewer = BangP remitter (BangP x) = Just x remitter _ = Nothing _AsP :: Prism' Pat (Name, Pat) _AsP = prism' reviewer remitter where reviewer (x, y) = AsP x y remitter (AsP x y) = Just (x, y) remitter _ = Nothing _WildP :: Prism' Pat () _WildP = prism' reviewer remitter where reviewer () = WildP remitter WildP = Just () remitter _ = Nothing _RecP :: Prism' Pat (Name, [FieldPat]) _RecP = prism' reviewer remitter where reviewer (x, y) = RecP x y remitter (RecP x y) = Just (x, y) remitter _ = Nothing _ListP :: Prism' Pat [Pat] _ListP = prism' reviewer remitter where reviewer = ListP remitter (ListP x) = Just x remitter _ = Nothing _SigP :: Prism' Pat (Pat, Type) _SigP = prism' reviewer remitter where reviewer (x, y) = SigP x y remitter (SigP x y) = Just (x, y) remitter _ = Nothing _ViewP :: Prism' Pat (Exp, Pat) _ViewP = prism' reviewer remitter where reviewer (x, y) = ViewP x y remitter (ViewP x y) = Just (x, y) remitter _ = Nothing _ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter where reviewer (x, y, z) = ForallT x y z remitter (ForallT x y z) = Just (x, y, z) remitter _ = Nothing _AppT :: Prism' Type (Type, Type) _AppT = prism' reviewer remitter where reviewer (x, y) = AppT x y remitter (AppT x y) = Just (x, y) remitter _ = Nothing _SigT :: Prism' Type (Type, Kind) _SigT = prism' reviewer remitter where reviewer (x, y) = SigT x y remitter (SigT x y) = Just (x, y) remitter _ = Nothing _VarT :: Prism' Type Name _VarT = prism' reviewer remitter where reviewer = VarT remitter (VarT x) = Just x remitter _ = Nothing _ConT :: Prism' Type Name _ConT = prism' reviewer remitter where reviewer = ConT remitter (ConT x) = Just x remitter _ = Nothing _PromotedT :: Prism' Type Name _PromotedT = prism' reviewer remitter where reviewer = PromotedT remitter (PromotedT x) = Just x remitter _ = Nothing _TupleT :: Prism' Type Int _TupleT = prism' reviewer remitter where reviewer = TupleT remitter (TupleT x) = Just x remitter _ = Nothing _UnboxedTupleT :: Prism' Type Int _UnboxedTupleT = prism' reviewer remitter where reviewer = UnboxedTupleT remitter (UnboxedTupleT x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _UnboxedSumT :: Prism' Type SumArity _UnboxedSumT = prism' reviewer remitter where reviewer = UnboxedSumT remitter (UnboxedSumT x) = Just x remitter _ = Nothing #endif _ArrowT :: Prism' Type () _ArrowT = prism' reviewer remitter where reviewer () = ArrowT remitter ArrowT = Just () remitter _ = Nothing _EqualityT :: Prism' Type () _EqualityT = prism' reviewer remitter where reviewer () = EqualityT remitter EqualityT = Just () remitter _ = Nothing _ListT :: Prism' Type () _ListT = prism' reviewer remitter where reviewer () = ListT remitter ListT = Just () remitter _ = Nothing _PromotedTupleT :: Prism' Type Int _PromotedTupleT = prism' reviewer remitter where reviewer = PromotedTupleT remitter (PromotedTupleT x) = Just x remitter _ = Nothing _PromotedNilT :: Prism' Type () _PromotedNilT = prism' reviewer remitter where reviewer () = PromotedNilT remitter PromotedNilT = Just () remitter _ = Nothing _PromotedConsT :: Prism' Type () _PromotedConsT = prism' reviewer remitter where reviewer () = PromotedConsT remitter PromotedConsT = Just () remitter _ = Nothing _StarT :: Prism' Type () _StarT = prism' reviewer remitter where reviewer () = StarT remitter StarT = Just () remitter _ = Nothing _ConstraintT :: Prism' Type () _ConstraintT = prism' reviewer remitter where reviewer () = ConstraintT remitter ConstraintT = Just () remitter _ = Nothing _LitT :: Prism' Type TyLit _LitT = prism' reviewer remitter where reviewer = LitT remitter (LitT x) = Just x remitter _ = Nothing _InfixT :: Prism' Type (Type, Name, Type) _InfixT = prism' reviewer remitter where reviewer (x, y, z) = InfixT x y z remitter (InfixT x y z) = Just (x, y, z) remitter _ = Nothing _UInfixT :: Prism' Type (Type, Name, Type) _UInfixT = prism' reviewer remitter where reviewer (x, y, z) = UInfixT x y z remitter (UInfixT x y z) = Just (x, y, z) remitter _ = Nothing _ParensT :: Prism' Type Type _ParensT = prism' reviewer remitter where reviewer = ParensT remitter (ParensT x) = Just x remitter _ = Nothing _WildCardT :: Prism' Type () _WildCardT = prism' reviewer remitter where reviewer () = WildCardT remitter WildCardT = Just () remitter _ = Nothing #if MIN_VERSION_template_haskell(2,15,0) _AppKindT :: Prism' Type (Type, Kind) _AppKindT = prism' reviewer remitter where reviewer (x, y) = AppKindT x y remitter (AppKindT x y) = Just (x, y) remitter _ = Nothing _ImplicitParamT :: Prism' Type (String, Type) _ImplicitParamT = prism' reviewer remitter where reviewer (x, y) = ImplicitParamT x y remitter (ImplicitParamT x y) = Just (x, y) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,16,0) _ForallVisT :: Prism' Type ([TyVarBndrUnit], Type) _ForallVisT = prism' reviewer remitter where reviewer (x, y) = ForallVisT x y remitter (ForallVisT x y) = Just (x, y) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,17,0) _MulArrowT :: Prism' Type () _MulArrowT = prism' reviewer remitter where reviewer () = MulArrowT remitter MulArrowT = Just () remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,19,0) _PromotedInfixT :: Prism' Type (Type, Name, Type) _PromotedInfixT = prism' reviewer remitter where reviewer (x, y, z) = PromotedInfixT x y z remitter (PromotedInfixT x y z) = Just (x, y, z) remitter _ = Nothing _PromotedUInfixT :: Prism' Type (Type, Name, Type) _PromotedUInfixT = prism' reviewer remitter where reviewer (x, y, z) = PromotedUInfixT x y z remitter (PromotedUInfixT x y z) = Just (x, y, z) remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,17,0) _SpecifiedSpec :: Prism' Specificity () _SpecifiedSpec = prism' reviewer remitter where reviewer () = SpecifiedSpec remitter SpecifiedSpec = Just () remitter _ = Nothing _InferredSpec :: Prism' Specificity () _InferredSpec = prism' reviewer remitter where reviewer () = InferredSpec remitter InferredSpec = Just () remitter _ = Nothing #endif #if MIN_VERSION_template_haskell(2,21,0) _BndrReq :: Prism' BndrVis () _BndrReq = prism' reviewer remitter where reviewer () = BndrReq remitter BndrReq = Just () remitter _ = Nothing _BndrInvis :: Prism' BndrVis () _BndrInvis = prism' reviewer remitter where reviewer () = BndrInvis remitter BndrInvis = Just () remitter _ = Nothing #endif -- | -- @ -- _PlainTV :: 'Prism'' ('TyVarBndr' flag) ('Name', flag) -- template-haskell-2.17+ -- _PlainTV :: 'Prism'' 'TyVarBndr' 'Name' -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,17,0) _PlainTV :: Prism' (TyVarBndr flag) (Name, flag) _PlainTV = prism' reviewer remitter where reviewer (x, y) = PlainTV x y remitter (PlainTV x y) = Just (x, y) remitter _ = Nothing #else _PlainTV :: Prism' TyVarBndr Name _PlainTV = prism' reviewer remitter where reviewer = PlainTV remitter (PlainTV x) = Just x remitter _ = Nothing #endif -- | -- @ -- _KindedTV :: 'Prism'' ('TyVarBndr' flag) ('Name', flag, 'Kind') -- template-haskell-2.17+ -- _KindedTV :: 'Prism'' 'TyVarBndr' ('Name', 'Kind') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,17,0) _KindedTV :: Prism' (TyVarBndr flag) (Name, flag, Kind) _KindedTV = prism' reviewer remitter where reviewer (x, y, z) = KindedTV x y z remitter (KindedTV x y z) = Just (x, y, z) remitter _ = Nothing #else _KindedTV :: Prism' TyVarBndr (Name, Kind) _KindedTV = prism' reviewer remitter where reviewer (x, y) = KindedTV x y remitter (KindedTV x y) = Just (x, y) remitter _ = Nothing #endif _NoSig :: Prism' FamilyResultSig () _NoSig = prism' reviewer remitter where reviewer () = NoSig remitter NoSig = Just () remitter _ = Nothing _KindSig :: Prism' FamilyResultSig Kind _KindSig = prism' reviewer remitter where reviewer = KindSig remitter (KindSig x) = Just x remitter _ = Nothing _TyVarSig :: Prism' FamilyResultSig TyVarBndrUnit _TyVarSig = prism' reviewer remitter where reviewer = TyVarSig remitter (TyVarSig x) = Just x remitter _ = Nothing _NumTyLit :: Prism' TyLit Integer _NumTyLit = prism' reviewer remitter where reviewer = NumTyLit remitter (NumTyLit x) = Just x remitter _ = Nothing _StrTyLit :: Prism' TyLit String _StrTyLit = prism' reviewer remitter where reviewer = StrTyLit remitter (StrTyLit x) = Just x remitter _ = Nothing #if MIN_VERSION_template_haskell(2,18,0) _CharTyLit :: Prism' TyLit Char _CharTyLit = prism' reviewer remitter where reviewer = CharTyLit remitter (CharTyLit x) = Just x remitter _ = Nothing #endif _NominalR :: Prism' Role () _NominalR = prism' reviewer remitter where reviewer () = NominalR remitter NominalR = Just () remitter _ = Nothing _RepresentationalR :: Prism' Role () _RepresentationalR = prism' reviewer remitter where reviewer () = RepresentationalR remitter RepresentationalR = Just () remitter _ = Nothing _PhantomR :: Prism' Role () _PhantomR = prism' reviewer remitter where reviewer () = PhantomR remitter PhantomR = Just () remitter _ = Nothing _InferR :: Prism' Role () _InferR = prism' reviewer remitter where reviewer () = InferR remitter InferR = Just () remitter _ = Nothing #if MIN_VERSION_template_haskell(2,12,0) _StockStrategy :: Prism' DerivStrategy () _StockStrategy = prism' reviewer remitter where reviewer () = StockStrategy remitter StockStrategy = Just () remitter _ = Nothing _AnyclassStrategy :: Prism' DerivStrategy () _AnyclassStrategy = prism' reviewer remitter where reviewer () = AnyclassStrategy remitter AnyclassStrategy = Just () remitter _ = Nothing _NewtypeStrategy :: Prism' DerivStrategy () _NewtypeStrategy = prism' reviewer remitter where reviewer () = NewtypeStrategy remitter NewtypeStrategy = Just () remitter _ = Nothing #endif lens-5.2.3/src/Numeric/0000755000000000000000000000000007346545000013044 5ustar0000000000000000lens-5.2.3/src/Numeric/Lens.hs0000644000000000000000000001276707346545000014316 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -------------------------------------------------------------------------------- -- | -- Module : Numeric.Lens -- Copyright : (C) 2012-16 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 -- * Arithmetic lenses , adding , subtracting , multiplying , dividing , exponentiating , negated , pattern Integral ) where import Control.Lens import Data.CallStack import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit) import Data.Maybe (fromMaybe) import Numeric (readInt, showIntAtBase) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Monoid (Sum(..)) -- | This t'Prism' can be used to model the fact that every t'Integral' -- type is a subset of 'Integer'. -- -- Embedding through the t'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 pattern Integral :: Integral a => a -> Integer pattern Integral a <- (preview integral -> Just a) where Integral a = review integral a -- | A prism that shows and reads integers in base-2 through base-36 -- -- Note: This is an improper prism, since leading 0s are stripped when reading. -- -- >>> "100" ^? base 16 -- Just 256 -- -- >>> 1767707668033969 ^. re (base 36) -- "helloworld" base :: (HasCallStack, 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' :: HasCallStack => 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' :: HasCallStack => 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 <&> _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 -- | @'adding' n = 'iso' (+n) (subtract n)@ -- -- >>> [1..3]^..traverse.adding 1000 -- [1001,1002,1003] adding :: Num a => a -> Iso' a a adding n = iso (+n) (subtract n) -- | @ -- 'subtracting' n = 'iso' (subtract n) ((+n) -- 'subtracting' n = 'from' ('adding' n) -- @ subtracting :: Num a => a -> Iso' a a subtracting n = iso (subtract n) (+n) -- | @'multiplying' n = iso (*n) (/n)@ -- -- Note: This errors for n = 0 -- -- >>> 5 & multiplying 1000 +~ 3 -- 5.003 -- -- >>> let fahrenheit = multiplying (9/5).adding 32 in 230^.from fahrenheit -- 110.0 multiplying :: (Fractional a, Eq a) => a -> Iso' a a multiplying 0 = error "Numeric.Lens.multiplying: factor 0" multiplying n = iso (*n) (/n) -- | @ -- 'dividing' n = 'iso' (/n) (*n) -- 'dividing' n = 'from' ('multiplying' n)@ -- -- Note: This errors for n = 0 dividing :: (Fractional a, Eq a) => a -> Iso' a a dividing 0 = error "Numeric.Lens.dividing: divisor 0" dividing n = iso (/n) (*n) -- | @'exponentiating' n = 'iso' (**n) (**recip n)@ -- -- Note: This errors for n = 0 -- -- >>> au (_Wrapping Sum . from (exponentiating 2)) (foldMapOf each) (3,4) == 5 -- True exponentiating :: (Floating a, Eq a) => a -> Iso' a a exponentiating 0 = error "Numeric.Lens.exponentiating: exponent 0" exponentiating n = iso (**n) (**recip n) -- | @'negated' = 'iso' 'negate' 'negate'@ -- -- >>> au (_Wrapping Sum . negated) (foldMapOf each) (3,4) == 7 -- True -- -- >>> au (_Wrapping Sum) (foldMapOf (each.negated)) (3,4) == -7 -- True negated :: Num a => Iso' a a negated = iso negate negate lens-5.2.3/src/Numeric/Natural/0000755000000000000000000000000007346545000014452 5ustar0000000000000000lens-5.2.3/src/Numeric/Natural/Lens.hs0000644000000000000000000000440407346545000015711 0ustar0000000000000000{-# language RankNTypes #-} {-# language PatternGuards #-} {-# language ViewPatterns #-} {-# language PatternSynonyms #-} -------------------------------------------------------------------------------- -- | -- Module : Numeric.Natural.Lens -- Copyright : (C) 2017 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Useful tools for Gödel numbering. ------------------------------------------------------------------------------- module Numeric.Natural.Lens ( _Pair , _Sum , _Naturals , pattern Pair , pattern Sum , pattern Naturals ) where import Control.Lens import Numeric.Natural -- | The natural numbers are isomorphic to the product of the natural numbers with itself. -- -- @N = N*N@ _Pair :: Iso' Natural (Natural, Natural) _Pair = iso hither (uncurry yon) where yon 0 0 = 0 yon m n = case quotRem m 2 of (q,r) -> r + 2 * yon n q -- rotation hither 0 = (0,0) hither n = case quotRem n 2 of (p,r) -> case hither p of (x,y) -> (r+2*y,x) -- rotation -- | The natural numbers are isomorphic to disjoint sums of natural numbers embedded as -- evens or odds. -- -- @N = 2*N@ _Sum :: Iso' Natural (Either Natural Natural) _Sum = iso hither yon where hither p = case quotRem p 2 of (q,0) -> Left q (q,1) -> Right q _ -> error "_Sum: impossible" yon (Left q) = 2*q yon (Right q) = 2*q+1 -- | The natural numbers are isomorphic to lists of natural numbers _Naturals :: Iso' Natural [Natural] _Naturals = iso hither yon where hither 0 = [] hither n | (h, t) <- (n-1)^._Pair = h : hither t yon [] = 0 yon (x:xs) = 1 + review _Pair (x, yon xs) -- | -- interleaves the bits of two natural numbers pattern Pair :: Natural -> Natural -> Natural pattern Pair x y <- (view _Pair -> (x,y)) where Pair x y = review _Pair (x,y) -- | -- @ -- Sum (Left q) = 2*q -- Sum (Right q) = 2*q+1 -- @ pattern Sum :: Either Natural Natural -> Natural pattern Sum s <- (view _Sum -> s) where Sum s = review _Sum s -- | -- @ -- Naturals [] = 0 -- Naturals (h:t) = 1 + Pair h (Naturals t) -- @ pattern Naturals :: [Natural] -> Natural pattern Naturals xs <- (view _Naturals -> xs) where Naturals xs = review _Naturals xs lens-5.2.3/src/System/Exit/0000755000000000000000000000000007346545000013637 5ustar0000000000000000lens-5.2.3/src/System/Exit/Lens.hs0000644000000000000000000000462107346545000015077 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : System.Exit.Lens -- Copyright : (C) 2013-16 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 , pattern ExitFailure_ , pattern ExitSuccess_ ) where import Prelude () import Control.Exception import Control.Exception.Lens import Control.Lens import Control.Lens.Internal.Prelude import System.Exit -- | Exit codes that a program can return with: class AsExitCode t where _ExitCode :: Prism' t ExitCode instance AsExitCode ExitCode where _ExitCode = id {-# INLINE _ExitCode #-} instance AsExitCode SomeException where _ExitCode = exception {-# INLINE _ExitCode #-} -- | indicates successful termination; -- -- @ -- '_ExitSuccess' :: 'Prism'' 'ExitCode' () -- '_ExitSuccess' :: 'Prism'' 'SomeException' () -- @ _ExitSuccess :: AsExitCode t => Prism' 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 t => Prism' 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 #-} pattern ExitSuccess_ :: AsExitCode s => s pattern ExitSuccess_ <- (has _ExitSuccess -> True) where ExitSuccess_ = review _ExitSuccess () pattern ExitFailure_ :: AsExitCode s => Int -> s pattern ExitFailure_ a <- (preview _ExitFailure -> Just a) where ExitFailure_ a = review _ExitFailure a lens-5.2.3/src/System/FilePath/0000755000000000000000000000000007346545000014422 5ustar0000000000000000lens-5.2.3/src/System/FilePath/Lens.hs0000644000000000000000000002165107346545000015664 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.FilePath.Lens -- Copyright : (C) 2012-16 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 Prelude () import Control.Monad.State as State import System.FilePath ( (), (<.>), splitExtension , takeBaseName, takeDirectory , takeExtension, takeFileName ) import Control.Lens.Internal.Prelude import Control.Lens hiding ((<.>)) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import System.FilePath (()) {- NB: Be very careful if you are planning to modify the doctest output in this module! Path separators are OS-dependent (\\ with Windows, / with Posix), so we take great care to avoid using separators in doctest output so that they will be valid on all operating systems. If you find yourself wanting to test a function that uses path separators in the output, it would be wise to: 1. Compare the tested expression and the expected results explicitly using (==). 2. Always use the function (and derived combinators) to construct path separators instead of typing them manually. That is, don't type out "foo/bar", but rather "foo" "bar". This way we can avoid leaking path separators into the output. See the doctest example for (~) for an example of how to do this. -} infixr 4 ~, <~, <<~, <.>~, <<.>~, <<<.>~ infix 4 =, <=, <<=, <.>=, <<.>=, <<<.>= -- | Modify the path by adding another path. -- -- >>> (both ~ "bin" $ ("hello","world")) == ("hello" "bin", "world" "bin") -- True -- -- @ -- ('~') :: t'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- ('~') :: t'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- ('~') :: t'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- ('~') :: t'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 'Lens'', 'Iso'', 'Setter'' or 'Traversal'' by adding a path. -- -- >>> execState (both = "bin") ("hello","world") == ("hello" "bin", "world" "bin") -- True -- -- @ -- ('=') :: '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 t'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 t'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 (<=) #-} -- | Add a path onto the end of the target of a t'Lens' and return the original -- value. -- -- When you do not need the original value, ('~') is more flexible. (<<~) :: Optical' (->) q ((,)FilePath) s FilePath -> FilePath -> q s (FilePath, s) l <<~ b = l $ \a -> (a, a b) {-# INLINE (<<~) #-} -- | Add a path onto the end of a target of a t'Lens' into your monad's state -- and return the old value. -- -- When you do not need the result of the operation, ('=') is more flexible. (<<=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> FilePath -> m FilePath l <<= b = l %%= \a -> (a, a b) {-# INLINE (<<=) #-} -- | Modify the path by adding an extension. -- -- >>> both <.>~ "txt" $ ("hello","world") -- ("hello.txt","world.txt") -- -- @ -- ('<.>~') :: t'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- ('<.>~') :: t'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- ('<.>~') :: t'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- ('<.>~') :: t'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 '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 t'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 t'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 (<<.>=) #-} -- | Add an extension onto the end of the target of a t'Lens' but -- return the old value -- -- >>> _1 <<<.>~ "txt" $ ("hello","world") -- ("hello",("hello.txt","world")) -- -- When you do not need the old value, ('<.>~') is more flexible. (<<<.>~) :: Optical' (->) q ((,)FilePath) s FilePath -> String -> q s (FilePath, s) l <<<.>~ b = l $ \a -> (a, a <.> b) {-# INLINE (<<<.>~) #-} -- | Add an extension onto the end of the target of a t'Lens' into your monad's -- state and return the old value. -- -- >>> runState (_1 <<<.>= "txt") ("hello","world") -- ("hello",("hello.txt","world")) -- -- When you do not need the old value, ('<.>=') is more flexible. (<<<.>=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> String -> m FilePath l <<<.>= b = l %%= \a -> (a, a <.> b) {-# INLINE (<<<.>=) #-} -- | A t'Lens' for reading and writing to the basename -- -- Note: This is /not/ a legal t'Lens' unless the outer 'FilePath' has both a directory -- and filename component and the generated basenames are not null and contain no directory -- separators. -- -- >>> (basename .~ "filename" $ "path" "name.png") == "path" "filename.png" -- True basename :: Lens' FilePath FilePath basename f p = (<.> takeExtension p) . (takeDirectory p ) <$> f (takeBaseName p) {-# INLINE basename #-} -- | A t'Lens' for reading and writing to the directory -- -- Note: this is /not/ a legal t'Lens' unless the outer 'FilePath' already has a directory component, -- and generated directories are not null. -- -- >>> (("long" "path" "name.txt") ^. directory) == "long" "path" -- True directory :: Lens' FilePath FilePath directory f p = ( takeFileName p) <$> f (takeDirectory p) {-# INLINE directory #-} -- | A t'Lens' for reading and writing to the extension -- -- Note: This is /not/ a legal t'Lens', unless you are careful to ensure that generated -- extension 'FilePath' components are either null or start with 'System.FilePath.extSeparator' -- and do not contain any internal 'System.FilePath.extSeparator's. -- -- >>> (extension .~ ".png" $ "path" "name.txt") == "path" "name.png" -- True extension :: Lens' FilePath FilePath extension f p = (n <.>) <$> f e where (n, e) = splitExtension p {-# INLINE extension #-} -- | A t'Lens' for reading and writing to the full filename -- -- Note: This is /not/ a legal t'Lens', unless you are careful to ensure that generated -- filename 'FilePath' components are not null and do not contain any -- elements of 'System.FilePath.pathSeparators's. -- -- >>> (filename .~ "name.txt" $ "path" "name.png") == "path" "name.txt" -- True filename :: Lens' FilePath FilePath filename f p = (takeDirectory p ) <$> f (takeFileName p) {-# INLINE filename #-} lens-5.2.3/src/System/IO/Error/0000755000000000000000000000000007346545000014326 5ustar0000000000000000lens-5.2.3/src/System/IO/Error/Lens.hs0000644000000000000000000000647307346545000015575 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : System.IO.Error.Lens -- Copyright : (C) 2012-2016 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 GHC.IO.Exception import System.IO import Foreign.C.Types -- * IOException Lenses -- | Where the error happened. location :: Lens' IOException String location f s = f (ioe_location s) <&> \e -> s { ioe_location = e } {-# INLINE location #-} -- | Error type specific information. description :: Lens' IOException String description f s = f (ioe_description s) <&> \e -> s { ioe_description = e } {-# INLINE description #-} -- | The handle used by the action flagging this error. handle :: Lens' IOException (Maybe Handle) handle f s = f (ioe_handle s) <&> \e -> s { ioe_handle = e } {-# INLINE handle #-} -- | 'fileName' the error is related to. -- fileName :: Lens' IOException (Maybe FilePath) fileName f s = f (ioe_filename s) <&> \e -> s { ioe_filename = e } {-# INLINE fileName #-} -- | 'errno' leading to this error, if any. -- errno :: Lens' IOException (Maybe CInt) errno f 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 f s = f (ioe_type s) <&> \e -> s { ioe_type = e } {-# INLINE errorType #-} -- * IOErrorType Prisms -- _AlreadyExists :: Prism' IOErrorType () _AlreadyExists = only AlreadyExists _NoSuchThing :: Prism' IOErrorType () _NoSuchThing = only NoSuchThing _ResourceBusy :: Prism' IOErrorType () _ResourceBusy = only ResourceBusy _ResourceExhausted :: Prism' IOErrorType () _ResourceExhausted = only ResourceExhausted _EOF :: Prism' IOErrorType () _EOF = only EOF _IllegalOperation :: Prism' IOErrorType () _IllegalOperation = only IllegalOperation _PermissionDenied :: Prism' IOErrorType () _PermissionDenied = only PermissionDenied _UserError :: Prism' IOErrorType () _UserError = only UserError _UnsatisfiedConstraints :: Prism' IOErrorType () _UnsatisfiedConstraints = only UnsatisfiedConstraints _SystemError :: Prism' IOErrorType () _SystemError = only SystemError _ProtocolError :: Prism' IOErrorType () _ProtocolError = only ProtocolError _OtherError :: Prism' IOErrorType () _OtherError = only OtherError _InvalidArgument :: Prism' IOErrorType () _InvalidArgument = only InvalidArgument _InappropriateType :: Prism' IOErrorType () _InappropriateType = only InappropriateType _HardwareFault :: Prism' IOErrorType () _HardwareFault = only HardwareFault _UnsupportedOperation :: Prism' IOErrorType () _UnsupportedOperation = only UnsupportedOperation _TimeExpired :: Prism' IOErrorType () _TimeExpired = only TimeExpired _ResourceVanished :: Prism' IOErrorType () _ResourceVanished = only ResourceVanished _Interrupted :: Prism' IOErrorType () _Interrupted = only Interrupted lens-5.2.3/tests/0000755000000000000000000000000007346545000012015 5ustar0000000000000000lens-5.2.3/tests/BigRecord.hs0000644000000000000000000001377207346545000014223 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module BigRecord where import Control.Lens data Big = Big { _a0 :: Int , _a1 :: Int , _a2 :: Int , _a3 :: Int , _a4 :: Int , _a5 :: Int , _a6 :: Int , _a7 :: Int , _a8 :: Int , _a9 :: Int , _a10 :: Int , _a11 :: Int , _a12 :: Int , _a13 :: Int , _a14 :: Int , _a15 :: Int , _a16 :: Int , _a17 :: Int , _a18 :: Int , _a19 :: Int , _a20 :: Int , _a21 :: Int , _a22 :: Int , _a23 :: Int , _a24 :: Int , _a25 :: Int , _a26 :: Int , _a27 :: Int , _a28 :: Int , _a29 :: Int , _a30 :: Int , _a31 :: Int , _a32 :: Int , _a33 :: Int , _a34 :: Int , _a35 :: Int , _a36 :: Int , _a37 :: Int , _a38 :: Int , _a39 :: Int , _a40 :: Int , _a41 :: Int , _a42 :: Int , _a43 :: Int , _a44 :: Int , _a45 :: Int , _a46 :: Int , _a47 :: Int , _a48 :: Int , _a49 :: Int , _a50 :: Int , _a51 :: Int , _a52 :: Int , _a53 :: Int , _a54 :: Int , _a55 :: Int , _a56 :: Int , _a57 :: Int , _a58 :: Int , _a59 :: Int , _a60 :: Int , _a61 :: Int , _a62 :: Int , _a63 :: Int , _a64 :: Int , _a65 :: Int , _a66 :: Int , _a67 :: Int , _a68 :: Int , _a69 :: Int , _a70 :: Int , _a71 :: Int , _a72 :: Int , _a73 :: Int , _a74 :: Int , _a75 :: Int , _a76 :: Int , _a77 :: Int , _a78 :: Int , _a79 :: Int , _a80 :: Int , _a81 :: Int , _a82 :: Int , _a83 :: Int , _a84 :: Int , _a85 :: Int , _a86 :: Int , _a87 :: Int , _a88 :: Int , _a89 :: Int , _a90 :: Int , _a91 :: Int , _a92 :: Int , _a93 :: Int , _a94 :: Int , _a95 :: Int , _a96 :: Int , _a97 :: Int , _a98 :: Int , _a99 :: Int } data Bigger = Bigger { _b0 :: Int , _b1 :: Int , _b2 :: Int , _b3 :: Int , _b4 :: Int , _b5 :: Int , _b6 :: Int , _b7 :: Int , _b8 :: Int , _b9 :: Int , _b10 :: Int , _b11 :: Int , _b12 :: Int , _b13 :: Int , _b14 :: Int , _b15 :: Int , _b16 :: Int , _b17 :: Int , _b18 :: Int , _b19 :: Int , _b20 :: Int , _b21 :: Int , _b22 :: Int , _b23 :: Int , _b24 :: Int , _b25 :: Int , _b26 :: Int , _b27 :: Int , _b28 :: Int , _b29 :: Int , _b30 :: Int , _b31 :: Int , _b32 :: Int , _b33 :: Int , _b34 :: Int , _b35 :: Int , _b36 :: Int , _b37 :: Int , _b38 :: Int , _b39 :: Int , _b40 :: Int , _b41 :: Int , _b42 :: Int , _b43 :: Int , _b44 :: Int , _b45 :: Int , _b46 :: Int , _b47 :: Int , _b48 :: Int , _b49 :: Int , _b50 :: Int , _b51 :: Int , _b52 :: Int , _b53 :: Int , _b54 :: Int , _b55 :: Int , _b56 :: Int , _b57 :: Int , _b58 :: Int , _b59 :: Int , _b60 :: Int , _b61 :: Int , _b62 :: Int , _b63 :: Int , _b64 :: Int , _b65 :: Int , _b66 :: Int , _b67 :: Int , _b68 :: Int , _b69 :: Int , _b70 :: Int , _b71 :: Int , _b72 :: Int , _b73 :: Int , _b74 :: Int , _b75 :: Int , _b76 :: Int , _b77 :: Int , _b78 :: Int , _b79 :: Int , _b80 :: Int , _b81 :: Int , _b82 :: Int , _b83 :: Int , _b84 :: Int , _b85 :: Int , _b86 :: Int , _b87 :: Int , _b88 :: Int , _b89 :: Int , _b90 :: Int , _b91 :: Int , _b92 :: Int , _b93 :: Int , _b94 :: Int , _b95 :: Int , _b96 :: Int , _b97 :: Int , _b98 :: Int , _b99 :: Int , _b100 :: Int , _b101 :: Int , _b102 :: Int , _b103 :: Int , _b104 :: Int , _b105 :: Int , _b106 :: Int , _b107 :: Int , _b108 :: Int , _b109 :: Int , _b110 :: Int , _b111 :: Int , _b112 :: Int , _b113 :: Int , _b114 :: Int , _b115 :: Int , _b116 :: Int , _b117 :: Int , _b118 :: Int , _b119 :: Int , _b120 :: Int , _b121 :: Int , _b122 :: Int , _b123 :: Int , _b124 :: Int , _b125 :: Int , _b126 :: Int , _b127 :: Int , _b128 :: Int , _b129 :: Int , _b130 :: Int , _b131 :: Int , _b132 :: Int , _b133 :: Int , _b134 :: Int , _b135 :: Int , _b136 :: Int , _b137 :: Int , _b138 :: Int , _b139 :: Int , _b140 :: Int , _b141 :: Int , _b142 :: Int , _b143 :: Int , _b144 :: Int , _b145 :: Int , _b146 :: Int , _b147 :: Int , _b148 :: Int , _b149 :: Int , _b150 :: Int , _b151 :: Int , _b152 :: Int , _b153 :: Int , _b154 :: Int , _b155 :: Int , _b156 :: Int , _b157 :: Int , _b158 :: Int , _b159 :: Int , _b160 :: Int , _b161 :: Int , _b162 :: Int , _b163 :: Int , _b164 :: Int , _b165 :: Int , _b166 :: Int , _b167 :: Int , _b168 :: Int , _b169 :: Int , _b170 :: Int , _b171 :: Int , _b172 :: Int , _b173 :: Int , _b174 :: Int , _b175 :: Int , _b176 :: Int , _b177 :: Int , _b178 :: Int , _b179 :: Int , _b180 :: Int , _b181 :: Int , _b182 :: Int , _b183 :: Int , _b184 :: Int , _b185 :: Int , _b186 :: Int , _b187 :: Int , _b188 :: Int , _b189 :: Int , _b190 :: Int , _b191 :: Int , _b192 :: Int , _b193 :: Int , _b194 :: Int , _b195 :: Int , _b196 :: Int , _b197 :: Int , _b198 :: Int , _b199 :: Int , _b200 :: Int , _b201 :: Int , _b202 :: Int , _b203 :: Int , _b204 :: Int , _b205 :: Int , _b206 :: Int , _b207 :: Int , _b208 :: Int , _b209 :: Int , _b210 :: Int , _b211 :: Int , _b212 :: Int , _b213 :: Int , _b214 :: Int , _b215 :: Int , _b216 :: Int , _b217 :: Int , _b218 :: Int , _b219 :: Int , _b220 :: Int , _b221 :: Int , _b222 :: Int , _b223 :: Int , _b224 :: Int , _b225 :: Int , _b226 :: Int , _b227 :: Int , _b228 :: Int , _b229 :: Int , _b230 :: Int , _b231 :: Int , _b232 :: Int , _b233 :: Int , _b234 :: Int , _b235 :: Int , _b236 :: Int , _b237 :: Int , _b238 :: Int , _b239 :: Int , _b240 :: Int , _b241 :: Int , _b242 :: Int , _b243 :: Int , _b244 :: Int , _b245 :: Int , _b246 :: Int , _b247 :: Int , _b248 :: Int , _b249 :: Int , _b250 :: Int , _b251 :: Int , _b252 :: Int , _b253 :: Int , _b254 :: Int , _b255 :: Int , _b256 :: Int , _b257 :: Int , _b258 :: Int , _b259 :: Int , _b260 :: Int , _b261 :: Int , _b262 :: Int , _b263 :: Int , _b264 :: Int , _b265 :: Int , _b266 :: Int , _b267 :: Int , _b268 :: Int , _b269 :: Int , _b270 :: Int , _b271 :: Int , _b272 :: Int , _b273 :: Int , _b274 :: Int , _b275 :: Int , _b276 :: Int , _b277 :: Int , _b278 :: Int , _b279 :: Int , _b280 :: Int , _b281 :: Int , _b282 :: Int , _b283 :: Int , _b284 :: Int , _b285 :: Int , _b286 :: Int , _b287 :: Int , _b288 :: Int , _b289 :: Int , _b290 :: Int , _b291 :: Int , _b292 :: Int , _b293 :: Int , _b294 :: Int , _b295 :: Int , _b296 :: Int , _b297 :: Int , _b298 :: Int , _b299 :: Int } makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Big makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Bigger lens-5.2.3/tests/T799.hs0000644000000000000000000000131307346545000013023 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Test 'makeFields' on a field whose type has a data family. Unlike for -- type families, for data families we do not generate type equality -- constraints, as they are not needed to avoid the issue in #754. -- -- This tests that the fix for #799 is valid by putting this in a module in -- which UndecidableInstances is not enabled. module T799 where import Control.Lens data family DF a newtype instance DF Int = FooInt Int data Bar = Bar { _barFoo :: DF Int } makeFields ''Bar checkBarFoo :: Lens' Bar (DF Int) checkBarFoo = foo lens-5.2.3/tests/T917.hs0000644000000000000000000000224307346545000013016 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module T917 where import Control.Lens import Data.Kind import Data.Proxy -- Like Data.Functor.Const, but redefined to ensure that it is poly-kinded -- across all versions of GHC, not just 8.0+ newtype Constant a (b :: k) = Constant a data T917OneA (a :: k -> Type) (b :: k -> Type) = MkT917OneA data T917OneB a b = MkT917OneB (T917OneA a (Const b)) $(makePrisms ''T917OneB) data T917TwoA (a :: k -> Type) (b :: k -> Type) = MkT917TwoA data T917TwoB a b = MkT917TwoB (T917TwoA a (Const b)) $(makeClassyPrisms ''T917TwoB) data family T917DataFam (a :: k) data instance T917DataFam (a :: Type) = MkT917DataFam { _unT917DataFam :: Proxy a } $(makeLenses 'MkT917DataFam) data T917GadtOne (a :: k) where MkT917GadtOne :: T917GadtOne (a :: Type) $(makePrisms ''T917GadtOne) data T917GadtTwo (a :: k) where MkT917GadtTwo :: T917GadtTwo (a :: Type) $(makePrisms ''T917GadtTwo) lens-5.2.3/tests/T972.hs0000644000000000000000000000071407346545000013020 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module T972 where import Control.Lens import Data.Proxy newtype Arc s = Arc { _unArc :: Int } data Direction = Negative | Positive data Dart s = Dart { _arc :: Arc s, _direction :: Direction } $(makeLenses ''Dart) data Fancy k (a :: k) = MkFancy { _unFancy1 :: k, _unFancy2 :: Proxy a } $(makeLenses ''Fancy) lens-5.2.3/tests/doctests.hs0000644000000000000000000000122707346545000014203 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module exists to add dependencies ----------------------------------------------------------------------------- module Main where main :: IO () main = do putStrLn "This test-suite exists only to add dependencies" putStrLn "To run doctests: " putStrLn " cabal build all --enable-tests" putStrLn " cabal-docspec" lens-5.2.3/tests/hunit.hs0000644000000000000000000003220507346545000013502 0ustar0000000000000000{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Main (hunit) -- Copyright : (C) 2012-14 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 (main) where import Control.Lens import Control.Monad.State import Data.Char import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif import Test.Framework.Providers.HUnit 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 = Map.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 = Map.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 = Map.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 = Map.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 } ] } case_correct_indexing_strict_text = map (\i -> StrictT.pack "12" ^? ix i) [-1..2] @?= [Nothing, Just '1', Just '2', Nothing] case_correct_indexing_lazy_text = map (\i -> LazyT.pack "12" ^? ix i) [-1..2] @?= [Nothing, Just '1', Just '2', Nothing] case_correct_indexing_strict_bytestring = map (\i -> StrictB.pack [1,2] ^? ix i) [-1..2] @?= [Nothing, Just 1, Just 2, Nothing] case_correct_indexing_lazy_bytestring = map (\i -> LazyB.pack [1,2] ^? ix i) [-1..2] @?= [Nothing, Just 1, Just 2, Nothing] main :: IO () main = defaultMain [ testGroup "Main" [ testCase "read record field" case_read_record_field , testCase "read state record field" case_read_state_record_field , testCase "read record field and apply function" case_read_record_field_and_apply_function , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function , testCase "write record field" case_write_record_field , testCase "write state record field" case_write_state_record_field , testCase "write record field and access new value" case_write_record_field_and_access_new_value , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value , testCase "write record field and access old value" case_write_record_field_and_access_old_value , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value , testCase "modify record field" case_modify_record_field , testCase "modify state record field" case_modify_state_record_field , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result , testCase "increment record field" case_increment_record_field , testCase "increment state record field" case_increment_state_record_field , testCase "append to record field" case_append_to_record_field , testCase "append to state record field" case_append_to_state_record_field , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value , testCase "read maybe map entry" case_read_maybe_map_entry , testCase "read maybe state map entry" case_read_maybe_state_map_entry , testCase "read map entry" case_read_map_entry , testCase "read state map entry" case_read_state_map_entry , testCase "modify map entry" case_modify_map_entry , testCase "insert maybe map entry" case_insert_maybe_map_entry , testCase "delete maybe map entry" case_delete_maybe_map_entry , testCase "read list entry" case_read_list_entry , testCase "write list entry" case_write_list_entry , testCase "write through list entry" case_write_through_list_entry , testCase "correct indexing strict text" case_correct_indexing_strict_text , testCase "correct indexing lazy text" case_correct_indexing_lazy_text , testCase "correct indexing strict bytestring" case_correct_indexing_strict_bytestring , testCase "correct indexing lazy bytestring" case_correct_indexing_lazy_bytestring ] ] lens-5.2.3/tests/properties.hs0000644000000000000000000001442507346545000014553 0ustar0000000000000000{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Main (properties) -- Copyright : (C) 2012-14 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.Lens import Test.QuickCheck import Test.Framework import Test.Framework.Providers.QuickCheck2 import Data.Char (isAlphaNum, isAscii, toUpper) import qualified Data.Text.Strict.Lens as Text import GHC.Exts (Constraint) import Numeric (showHex, showOct, showSigned) import Numeric.Lens import Control.Lens.Properties (isIso, isLens, isPrism, isSetter, isTraversal) #include "lens-common.h" -- 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_6 = isLens (_6 :: Lens' ((),(),(),(),Int,Bool) Bool) prop_7 = isLens (_7 :: Lens' ((),(),(),(),(),Int,Bool) Bool) prop_8 = isLens (_8 :: Lens' ((),(),(),(),(),(),Int,Bool) Bool) prop_9 = isLens (_9 :: Lens' ((),(),(),(),(),(),(),Int,Bool) Bool) prop_10 = isLens (_10 :: Lens' ((),(),(),(),(),(),(),(),Int,Bool) Bool) 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_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_prefixed s = isPrism (prefixed s :: Prism' String String) -- Data.Text.Lens prop_text s = s^.Text.packed.from Text.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 :: Maybe Integer) where isValid = (not . null) sPos && all isValidChar sPos sPos = case s of { ('-':s') -> s'; _ -> s } isValidChar c = isAscii c && isAlphaNum c -- Things that should typecheck but that we don't need to run data Foo (a :: Constraint) (b :: Constraint) where Foo :: Foo (Num Int) b sampleExtremePoly :: Equality s t a b -> Foo a (Functor b) -> Foo s (Functor t) sampleExtremePoly f foo = f foo samplePolyEquality :: Equality Monad Identity Monad Identity samplePolyEquality f = f lessSimplePoly :: forall KVS(k1 k2) (a :: k1) (b :: k2) . Equality a b a b lessSimplePoly f = f equalityAnEqualityPoly :: forall KVS(k1 k2) (s :: k1) (t :: k2) (a :: k1) (b :: k2) . Equality s t a b -> AnEquality s t a b equalityAnEqualityPoly f = f equalityIso :: Equality s t a b -> Iso s t a b equalityIso f = f main :: IO () main = defaultMain [ testGroup "Main" [ testProperty "1" prop_1 , testProperty "2" prop_2 , testProperty "3" prop_3 , testProperty "4" prop_4 , testProperty "5" prop_5 , testProperty "6" prop_6 , testProperty "7" prop_7 , testProperty "8" prop_8 , testProperty "9" prop_9 , testProperty "10" prop_10 , testProperty "2 2" prop_2_2 , testProperty "mapped" prop_mapped , testProperty "mapped mapped" prop_mapped_mapped , testProperty "both" prop_both , testProperty "traverseLeft" prop_traverseLeft , testProperty "traverseRight" prop_traverseRight , testProperty "simple" prop_simple , testProperty " Left" prop__Left , testProperty " Right" prop__Right , testProperty " Just" prop__Just , testProperty "prefixed" prop_prefixed , testProperty "text" prop_text , testProperty "base show" prop_base_show , testProperty "base read" prop_base_read , testProperty "base readFail" prop_base_readFail ] ] lens-5.2.3/tests/templates.hs0000644000000000000000000003103207346545000014346 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Main (templates) -- Copyright : (C) 2012-14 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) import BigRecord () import T799 () import T917 () import T972 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar checkBaz :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') checkBaz = baz data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } makeLenses ''Quux checkQuaffle :: Lens (Quux a b) (Quux a' b') Int Int checkQuaffle = quaffle checkQuartz :: Lens (Quux a b) (Quux a' b') Double Double checkQuartz = quartz data Quark a = Qualified { _gaffer :: a } | Unqualified { _gaffer :: a, _tape :: a } makeLenses ''Quark checkGaffer :: Lens' (Quark a) a checkGaffer = gaffer checkTape :: Traversal' (Quark a) a checkTape = tape data Hadron a b = Science { _a1 :: a, _a2 :: a, _c :: b } makeLenses ''Hadron checkA1 :: Lens' (Hadron a b) a checkA1 = a1 checkA2 :: Lens' (Hadron a b) a checkA2 = a2 checkC :: Lens (Hadron a b) (Hadron a b') b b' checkC = c data Perambulation a b = Mountains { _terrain :: a, _altitude :: b } | Beaches { _terrain :: a, _dunes :: a } makeLenses ''Perambulation checkTerrain :: Lens' (Perambulation a b) a checkTerrain = terrain checkAltitude :: Traversal (Perambulation a b) (Perambulation a b') b b' checkAltitude = altitude checkDunes :: Traversal' (Perambulation a b) a checkDunes = dunes makeLensesFor [("_terrain", "allTerrain"), ("_dunes", "allTerrain")] ''Perambulation checkAllTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a' checkAllTerrain = allTerrain data LensCrafted a = Still { _still :: a } | Works { _still :: a } makeLenses ''LensCrafted checkStill :: Lens (LensCrafted a) (LensCrafted b) a b checkStill = still data Task a = Task { taskOutput :: a -> IO () , taskState :: a , taskStop :: IO () } makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task checkOutputLens :: Lens' (Task a) (a -> IO ()) checkOutputLens = outputLens checkStateLens :: Lens' (Task a) a checkStateLens = stateLens checkStopLens :: Lens' (Task a) (IO ()) checkStopLens = stopLens 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 checkMono :: HasMono t a => Lens' t (Mono a) checkMono = mono checkMono' :: Lens' (Mono a) (Mono a) checkMono' = mono checkMonoFoo :: HasMono t a => Lens' t a checkMonoFoo = monoFoo checkMonoBar :: HasMono t a => Lens' t Int checkMonoBar = monoBar data Nucleosis = Nucleosis { _nuclear :: Mono Int } makeClassy ''Nucleosis -- class HasNucleosis t where -- nucleosis :: Simple Lens t Nucleosis -- instance HasNucleosis Nucleosis checkNucleosis :: HasNucleosis t => Lens' t Nucleosis checkNucleosis = nucleosis checkNucleosis' :: Lens' Nucleosis Nucleosis checkNucleosis' = nucleosis checkNuclear :: HasNucleosis t => Lens' t (Mono Int) checkNuclear = nuclear instance HasMono Nucleosis Int where mono = nuclear -- Dodek's example data Foo = Foo { _fooX, _fooY :: Int } makeClassy ''Foo checkFoo :: HasFoo t => Lens' t Foo checkFoo = foo checkFoo' :: Lens' Foo Foo checkFoo' = foo checkFooX :: HasFoo t => Lens' t Int checkFooX = fooX checkFooY :: HasFoo t => Lens' t Int checkFooY = fooY data Dude a = Dude { dudeLevel :: Int , dudeAlias :: String , dudeLife :: () , dudeThing :: a } makeFields ''Dude checkLevel :: HasLevel t a => Lens' t a checkLevel = level checkLevel' :: Lens' (Dude a) Int checkLevel' = level checkAlias :: HasAlias t a => Lens' t a checkAlias = alias checkAlias' :: Lens' (Dude a) String checkAlias' = alias checkLife :: HasLife t a => Lens' t a checkLife = life checkLife' :: Lens' (Dude a) () checkLife' = life checkThing :: HasThing t a => Lens' t a checkThing = thing checkThing' :: Lens' (Dude a) a checkThing' = thing data Lebowski a = Lebowski { _lebowskiAlias :: String , _lebowskiLife :: Int , _lebowskiMansion :: String , _lebowskiThing :: Maybe a } makeFields ''Lebowski checkAlias2 :: Lens' (Lebowski a) String checkAlias2 = alias checkLife2 :: Lens' (Lebowski a) Int checkLife2 = life checkMansion :: HasMansion t a => Lens' t a checkMansion = mansion checkMansion' :: Lens' (Lebowski a) String checkMansion' = mansion checkThing2 :: Lens' (Lebowski a) (Maybe a) checkThing2 = thing type family Fam a type instance Fam Int = String data FamRec a = FamRec { _famRecThing :: Fam a , _famRecUniqueToFamRec :: Fam a } makeFields ''FamRec checkFamRecThing :: Lens' (FamRec a) (Fam a) checkFamRecThing = thing checkFamRecUniqueToFamRec :: Lens' (FamRec a) (Fam a) checkFamRecUniqueToFamRec = uniqueToFamRec checkFamRecView :: FamRec Int -> String checkFamRecView = view thing data AbideConfiguration a = AbideConfiguration { _acLocation :: String , _acDuration :: Int , _acThing :: a } makeLensesWith abbreviatedFields ''AbideConfiguration checkLocation :: HasLocation t a => Lens' t a checkLocation = location checkLocation' :: Lens' (AbideConfiguration a) String checkLocation' = location checkDuration :: HasDuration t a => Lens' t a checkDuration = duration checkDuration' :: Lens' (AbideConfiguration a) Int checkDuration' = duration checkThing3 :: Lens' (AbideConfiguration a) a checkThing3 = thing dudeDrink :: String dudeDrink = (Dude 9 "El Duderino" () "white russian") ^. thing lebowskiCarpet :: Maybe String lebowskiCarpet = (Lebowski "Mr. Lebowski" 0 "" (Just "carpet")) ^. thing abideAnnoyance :: String abideAnnoyance = (AbideConfiguration "the tree" 10 "the wind") ^. thing declareLenses [d| data Quark1 a = Qualified1 { gaffer1 :: a } | Unqualified1 { gaffer1 :: a, tape1 :: a } |] -- data Quark1 a = Qualified1 a | Unqualified1 a a checkGaffer1 :: Lens' (Quark1 a) a checkGaffer1 = gaffer1 checkTape1 :: Traversal' (Quark1 a) a checkTape1 = tape1 declarePrisms [d| data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp } |] -- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp } checkLit :: Int -> Exp checkLit = Lit checkVar :: String -> Exp checkVar = Var checkLambda :: String -> Exp -> Exp checkLambda = Lambda check_Lit :: Prism' Exp Int check_Lit = _Lit check_Var :: Prism' Exp String check_Var = _Var check_Lambda :: Prism' Exp (String, Exp) check_Lambda = _Lambda declarePrisms [d| data Banana = Banana Int String |] -- data Banana = Banana Int String check_Banana :: Iso' Banana (Int, String) check_Banana = _Banana cavendish :: Banana cavendish = _Banana # (4, "Cavendish") data family Family a b c declareLenses [d| data instance Family Int (a, b) a = FamilyInt { fm0 :: (b, a), fm1 :: Int } |] -- data instance Family Int (a, b) a = FamilyInt a b checkFm0 :: Lens (Family Int (a, b) a) (Family Int (a', b') a') (b, a) (b', a') checkFm0 = fm0 checkFm1 :: Lens' (Family Int (a, b) a) Int checkFm1 = fm1 class Class a where data Associated a method :: a -> Int declareLenses [d| instance Class Int where data Associated Int = AssociatedInt { mochi :: Double } method = id |] -- instance Class Int where -- data Associated Int = AssociatedInt Double -- method = id checkMochi :: Iso' (Associated Int) Double checkMochi = mochi declareFields [d| data DeclaredFields f a = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int } | DeclaredField2 { declaredFieldsC0 :: String , declaredFieldsB0 :: Int } deriving (Show) |] checkA0 :: HasA0 t a => Traversal' t a checkA0 = a0 checkB0 :: HasB0 t a => Lens' t a checkB0 = b0 checkC0 :: HasC0 t a => Traversal' t a checkC0 = c0 checkA0' :: Traversal' (DeclaredFields f a) (f a) checkA0' = a0 checkB0' :: Lens' (DeclaredFields f a) Int checkB0' = b0 checkC0' :: Traversal' (DeclaredFields f a) String checkC0' = c0 declareFields [d| data Aardvark = Aardvark { aardvarkAlbatross :: Int } data Baboon = Baboon { baboonAlbatross :: Int } |] checkAardvark :: Lens' Aardvark Int checkAardvark = albatross checkBaboon :: Lens' Baboon Int checkBaboon = albatross data Rank2Tests = C1 { _r2length :: forall a. [a] -> Int , _r2nub :: forall a. Eq a => [a] -> [a] } | C2 { _r2length :: forall a. [a] -> Int } makeLenses ''Rank2Tests checkR2length :: Getter Rank2Tests ([a] -> Int) checkR2length = r2length checkR2nub :: Eq a => Fold Rank2Tests ([a] -> [a]) checkR2nub = r2nub data PureNoFields = PureNoFieldsA | PureNoFieldsB { _pureNoFields :: Int } makeLenses ''PureNoFields data ReviewTest where ReviewTest :: a -> ReviewTest makePrisms ''ReviewTest -- test FieldNamers data CheckUnderscoreNoPrefixNamer = CheckUnderscoreNoPrefixNamer { _fieldUnderscoreNoPrefix :: Int } makeLensesWith (lensRules & lensField .~ underscoreNoPrefixNamer ) ''CheckUnderscoreNoPrefixNamer checkUnderscoreNoPrefixNamer :: Lens' CheckUnderscoreNoPrefixNamer Int checkUnderscoreNoPrefixNamer = fieldUnderscoreNoPrefix -- how can we test NOT generating a lens for some fields? data CheckMappingNamer = CheckMappingNamer { fieldMappingNamer :: String } makeLensesWith (lensRules & lensField .~ (mappingNamer (return . ("hogehoge_" ++)))) ''CheckMappingNamer checkMappingNamer :: Lens' CheckMappingNamer String checkMappingNamer = hogehoge_fieldMappingNamer data CheckLookingupNamer = CheckLookingupNamer { fieldLookingupNamer :: Int } makeLensesWith (lensRules & lensField .~ (lookingupNamer [("fieldLookingupNamer", "foobarFieldLookingupNamer")])) ''CheckLookingupNamer checkLookingupNamer :: Lens' CheckLookingupNamer Int checkLookingupNamer = foobarFieldLookingupNamer data CheckUnderscoreNamer = CheckUnderscoreNamer { _hogeprefix_fieldCheckUnderscoreNamer :: Int } makeLensesWith (defaultFieldRules & lensField .~ underscoreNamer) ''CheckUnderscoreNamer checkUnderscoreNamer :: Lens' CheckUnderscoreNamer Int checkUnderscoreNamer = fieldCheckUnderscoreNamer data CheckCamelCaseNamer = CheckCamelCaseNamer { _checkCamelCaseNamerFieldCamelCaseNamer :: Int } makeLensesWith (defaultFieldRules & lensField .~ camelCaseNamer) ''CheckCamelCaseNamer checkCamelCaseNamer :: Lens' CheckCamelCaseNamer Int checkCamelCaseNamer = fieldCamelCaseNamer data CheckAbbreviatedNamer = CheckAbbreviatedNamer { _hogeprefixFieldAbbreviatedNamer :: Int } makeLensesWith (defaultFieldRules & lensField .~ abbreviatedNamer ) ''CheckAbbreviatedNamer checkAbbreviatedNamer :: Lens' CheckAbbreviatedNamer Int checkAbbreviatedNamer = fieldAbbreviatedNamer -- Ensure that `makeClassyPrisms` doesn't generate a redundant catch-all case (#866) data T866 = MkT866 $(makeClassyPrisms ''T866) -- Ensure that `makeClassyPrisms` doesn't generate duplicate prism names for -- data types that share a name with one of its constructors (#865) data T865 = T865 | T865a | T865b T866 $(makeClassyPrisms ''T865) instance AsT866 T865 where _T866 = __T865 . _T866 -- {make,declare}Wrapped test cases for ordinary data types newtype T997A a = MkT997A a $(makeWrapped ''T997A) $(declareWrapped [d| newtype T997B b = MkT997B b |]) -- {make,declare}Wrapped test cases for data family instances (#997) data family T997FamA a newtype instance T997FamA a = MkT997FamA a $(makeWrapped 'MkT997FamA) $(declareWrapped [d| data family T997FamB b newtype instance T997FamB b = MkT997FamB b |]) -- Ensure that a data type defined in a TH quote can have a field whose type -- references another data type defined in the same quote (#1032) declareFields [d| data T1032A = T1032A { t1032ASubB :: T1032B } data T1032B = T1032B { t1032BB :: Int } |] main :: IO () main = putStrLn "test/templates.hs: ok"