diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ dist/ +dist-newstyle/ .hsenv/ docs wiki @@ -12,5 +13,9 @@ *.hi *~ *# +cabal.project.local .cabal-sandbox/ cabal.sandbox.config +.stack-work/ +codex.tags +.ghc.environment.* diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,22 @@ +- 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 &~" diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,60 +0,0 @@ -language: haskell - -env: - - GHCVER=7.4.2 - - GHCVER=7.6.3 - - GHCVER=7.8.1 - - GHCVER=head - # - > - # GHCVER=7.4.2 - # MODE="-fsafe" - -matrix: - allow_failures: - - env: GHCVER=head - -before_install: - # If $GHCVER is the one travis has, don't bother reinstalling it. - # We can also have faster builds by installing some libraries with - # `apt`. If it isn't, install the GHC we want from hvr's PPA along - # with cabal-1.18. - - | - if [ $GHCVER = `ghc --numeric-version` ]; then - # Try installing some of the build-deps with apt-get for speed. - travis/cabal-apt-install --enable-tests $MODE - export CABAL=cabal - else - # Install the GHC we want from hvr's PPA - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy - export CABAL=cabal-1.18 - export PATH=/opt/ghc/$GHCVER/bin:$PATH - fi - # Uncomment whenever hackage is down. - # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update - - $CABAL update - - # Update happy when building with GHC head - - | - if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.1" ]; then - $CABAL install happy alex - export PATH=$HOME/.cabal/bin:$PATH - fi - -install: - - $CABAL install --dependencies-only --enable-tests - - $CABAL configure -flib-Werror --enable-tests $MODE - -script: - - $CABAL build - - $CABAL test --show-details=always - - scripts/stats - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" diff --git a/.vim.custom b/.vim.custom --- a/.vim.custom +++ b/.vim.custom @@ -15,7 +15,7 @@ syntax on " search for the tags file anywhere between here and / -set tags=TAGS;/ +set tags=TAGS;/,codex.tags;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ diff --git a/AUTHORS.markdown b/AUTHORS.markdown --- a/AUTHORS.markdown +++ b/AUTHORS.markdown @@ -36,6 +36,9 @@ * [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). diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,7 +1,682 @@ -4.1.2.1 +5.3.6 [2026.01.10] +------------------ +* Allow building with `template-haskell-2.24.*` (GHC 9.14). +* Add `_SpecialiseEP` to `Language.Haskell.TH.Lens` (when building with + `template-haskell-2.24.*`/GHC 9.14 or later). + +5.3.5 [2025.06.17] +------------------ +* Replace `test-framework` with `tasty` in the test suite. + +5.3.4 [2025.03.03] +------------------ +* Reduce the arity of `foldr1Of`, `foldl1Of`, `foldrOf'`, `foldlOf'`, + `foldr1Of'`, `foldl1Of'`, `foldrMOf`, and `foldlMOf` so that GHC is more + eager to inline them. On a simple benchmark involving `sumOf` (defined in + terms of `foldlOf'`), this improves performance by 8x. +* Add `Ixed`, `Cons`, `Each`, `AsEmpty`, `Reversing`, and `Rewrapped` instances + for strict boxed vectors when building with `vector-0.13.2` or later. +* Add an `AsEmpty` instance for primitive `Vector`s. + +5.3.3 [2024.12.28] +------------------ +* Add `makeFieldsId`, which generates overloaded field accessors using the + same names as the underlying fields. This is intended for use with the + `NoFieldSelectors` and `DuplicateRecordFields` language extensions. + + Also add `classIdFields :: LensRules` and `classIdNamer :: FieldNamer`, both + of which use the same naming rules as `makeFieldsId`. +* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to + `template-haskell-2.23.0.0`: + * Add an `_OrP` `Prism` for the `Pat` data type. + * Add `_ForallE`, `_ForallVisE`, and `_ConstrainedE` `Prism`s for the `Exp` + data type. + +5.3.2 [2024.05.12] +------------------ +* Define the following lenses that perform an operation and result the old + result: + * `(<<<>:~)` (prepend to the front via `(<>)` and return the old result) + * `(<<<|~)` (prepend to the front via `(<|)` and return the old result) + * `(<<|>~)` (append to the back via `(|>)` and return the old result) + + Each of these also has a variant that end with `=` instead of `~` (e.g., + `(<<<>:=)`) for working in a `MonadState` setting. +* Re-export `(<>:~)`, `(<<>:~)`, `(<|~)`, `(<<|~)`, `(|>~)`, and `(<|>~)` (as + well as their variants which end with `=` instead of `~`, and their variants + which return the old result) from `Control.Lens.Operators`. + +5.3.1 [2024.05.05] +------------------ +* Add a `Magnify` instance for the CPS variant of `RWST` when building with + `mtl-2.3` or later. + +5.3 [2024.05.04] +---------------- +* Allow building with GHC 9.10. +* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to + `template-haskell-2.22.0.0`: + * The `_InfixD` `Prism` now focuses on `(Fixity, NamespaceSpecifier, Name)` + when building with `template-haskell-2.22.0.0` or later. + * Add `Prism`s for the newly introduced `NamespaceSpecifier` data type. + * Add `_TypeP` and `_InvisP` `Prism`s for the `Pat` data type. + * Add a `_TypeE` `Prism` for the `Exp` data type. + * Add a `_SCCP` `Prism` for the `Pragma` data type. +* Add the following `Setter`s for prepending and appending elements: + * `(<>:~)`: prepend an element to the front via `(<>)`. + * `(<<>:~)`: prepend an element to the front via `(<>)` and return the result. + * `(<|~)`: cons an element to the front via `(<|)`. + * `(<<|~)`: cons an element to the front via `(<|)` and return the result. + * `(|>~)`: snoc an element to the back via `(|>)`. + * `(<|>~)`: snoc an element to the back via `(|>)` and return the result. + + Each of these also has a variant that end with `=` instead of `~` (e.g., + `(<>:=)`) for working in a `MonadState` setting. + +5.2.3 [2023.08.24] +------------------ +* Allow building with GHC 9.8. +* 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 ----- -* Bump `scientific` upper bound to < 0.4 +* 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`. @@ -83,7 +758,7 @@ * 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. +* 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. diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 --- a/HLint.hs +++ /dev/null @@ -1,37 +0,0 @@ -import "hint" HLint.HLint - -ignore "Reduce duplication" -ignore "Redundant lambda" -ignore "Use >=>" -ignore "Use const" - --- Used hlint --find src/ in the lens repo to generate this: -infixl 9 :> - -infixr 9 <.>, <., .>, ... -infixr 9 #. - -infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! -infixl 8 ^., ^@. -infixl 8 ^# -infixl 8 .# - -infixr 8 ^!, ^@! - -infixr 4 ~, <~, <.>~, <<.>~ -infixr 4 <#~, #~, #%~, <#%~, #%%~ -infixr 4 .|.~, .&.~, <.|.~, <.&.~ -infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~ -infixr 4 %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>= -infix 4 <#=, #=, #%=, <#%=, #%%= -infix 4 .|.=, .&.=, <.|.=, <.&.= -infix 4 %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %= -infix 4 %%@=, <%@=, %%=, <+=, <*=, <-=, , ?? diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2012-2014 Edward Kmett +Copyright 2012-2016 Edward Kmett All rights reserved. @@ -12,10 +12,6 @@ 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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ Lens: Lenses, Folds, and Traversals ================================== -[![Build Status](https://secure.travis-ci.org/ekmett/lens.png)](http://travis-ci.org/ekmett/lens) +[![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). @@ -9,13 +9,14 @@ The [FAQ](https://github.com/ekmett/lens/wiki/FAQ), which provides links to a large number of different resources for learning about lenses and an overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [overview](https://github.com/ekmett/lens/wiki/Overview) and some [examples](https://github.com/ekmett/lens/wiki/Examples). -Documentation is available through [github](http://ekmett.github.com/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. +Documentation is available through [github](https://ekmett.github.io/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. Field Guide ----------- -[![Lens Hierarchy](https://s3.amazonaws.com/creately-published/h5nyo9ne1)](https://creately.com/diagram/h5nyo9ne1/LBbRz63yg4yQsTXGLtub1bQU4%3D) +[![Lens Hierarchy](https://raw.githubusercontent.com/wiki/ekmett/lens/images/Hierarchy.png)](https://creately.com/diagram/h5nyo9ne1/QZ9UBOtw4AJWtmAKYK3wT8Mm1HM%3D) + Examples -------- @@ -192,223 +193,49 @@ 5 ``` -You can automatically derive isomorphisms for your own newtypes with `makeIso`. e.g. +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) -makeIso ''Neither +makePrisms ''Neither ``` will automatically derive ```haskell -neither :: Iso (Neither a b) (Neither c d) (Either a b) (Either c d) -nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d) +_Neither :: Iso (Neither a b) (Neither c d) (Either a b) (Either c d) ``` such that ```haskell -from neither = nor -from nor = neither -neither.nor = id -nor.neither = id +_Neither.from _Neither = id +from _Neither._Neither = id ``` -There is also a fully operational, but simple game of [Pong](https://github.com/ekmett/lens/blob/master/examples/Pong.hs) in the [examples/](https://github.com/ekmett/lens/blob/master/examples/) folder. +Alternatively, you can use `makeLenses` to automatically derive isomorphisms for your own newtypes. e.g.. -There are also a couple of hundred examples distributed throughout the haddock documentation. +```hs +makeLenses ''Neither +``` -Operators -========= +will automatically derive -(See [`wiki/Operators`](https://github.com/ekmett/lens/wiki/Operators)) +```hs +nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d) +``` - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Combinator(s)w/ ResultStatefulw/ ResultNotes
Control.Lens
view,views,^. - use,uses - View target(s). view works like use over a MonadReader
set, .~<.~.=assign,<.=Replace target(s). <<.~ and - <<.= - return the old value
over,mapOf,%~<%~%=<%=Update target(s). <<%~ and - <<%= - return the old value
id,traverseOf,%%~ - %%= - Update target(s) with an Applicative or auxiliary result
+~<+~+=<+=Add to target(s)
-~<-~-=<-=Subtract from target(s)
*~<*~*=<*=Multiply target(s)
//~<//~//=<//=Divide target(s)
^~<^~^=<^=Raise target(s) to a non-negative Integral power
^^~<^^~^^=<^^=Raise target(s) to an Integral power
**~<**~**=<**=Raise target(s) to an arbitrary power
||~<||~||=<||=Logically or target(s)
&&~<&&~&&=<&&=Logically and target(s)
<>~<<>~<>=<<>=mappend to the target monoidal value(s)
headOf,^? - Return Just the first target or Nothing
toListOf,^.. - Return a list of the target(s)
perform,performs^! - - - Perform monadic action(s)
Control.Lens (Indexed)
iover,imapOf,%@~<%@~%@=<%@=Update target(s) with access to the index.
withIndex,itraverseOf,%%@~ - %%@= - Update target(s) with an Applicative or auxiliary result with access to the index.
Data.Bits.Lens
.|.~<.|.~.|.=<.|.=Bitwise or target(s)
.&.~<.&.~.&.=<.&.=Bitwise and target(s)
System.FilePath.Lens
</>~<</>~</>=<</>=Append a relative path to a FilePath
<.>~<<.>~<.>=<<.>=Append a file extension to a FilePath
+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 IRC channel on irc.freenode.net. +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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,55 +1,6 @@ -#!/usr/bin/runhaskell \begin{code} -{-# OPTIONS_GHC -Wall #-} module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Text ( display ) -import Distribution.Verbosity ( Verbosity, normal ) -import System.FilePath ( () ) - +import Distribution.Simple (defaultMain) main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - , postHaddock = \args flags pkg lbi -> do - copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")] - postHaddock simpleUserHooks args flags pkg lbi - } - -haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath -haddockOutputDir flags pkg = destDir where - baseDir = case haddockDistPref flags of - NoFlag -> "." - Flag x -> x - destDir = baseDir "doc" "html" display (packageName pkg) - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - +main = defaultMain \end{code} diff --git a/benchmarks/alongside.hs b/benchmarks/alongside.hs --- a/benchmarks/alongside.hs +++ b/benchmarks/alongside.hs @@ -1,7 +1,10 @@ {-# 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 @@ -9,7 +12,6 @@ import Control.Lens import Criterion.Main import Data.Functor.Compose -import Data.Functor.Identity -- | A finally encoded Store newtype Experiment a b s = Experiment { runExperiment :: forall f. Functor f => (a -> f b) -> f s } @@ -70,33 +72,32 @@ -- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') -- {-# INLINE alongside'#-} -compound :: Lens s t a b - -> Lens s' t' a' b' - -> Lens (s,s') (t,t') (a,a') (b,b') +compound :: 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 t a b - -> Lens s' t' a' b' - -> Lens s'' t'' a'' b'' - -> Lens s''' t''' a''' b''' - -> Lens s'''' t'''' a'''' b'''' - -> Lens (s, (s', (s'', (s''', s'''')))) - (t, (t', (t'', (t''', t'''')))) +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'''')))) - (b, (b', (b'', (b''', b'''')))) compound5 l l' l'' l''' l'''' = lens (\(s, (s', (s'', (s''', s'''')))) -> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) ) (\(s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t'''')))) -> (set l t s, (set l' t' s', (set l'' t'' s'', (set l''' t''' s''', set l'''' t'''' s'''')))) ) +main :: IO () main = defaultMain - [ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", 1), (2, "there!")) - , bench "trial1" $ nf (view $ trial _1 _2) (("hi", 1), (2, "there!")) - , bench "half1" $ nf (view $ half _1 _2) (("hi", 1), (2, "there!")) - , bench "compound1" $ nf (view $ compound _1 _2) (("hi", 1), (2, "there!")) + [ bench "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))))) @@ -107,3 +108,4 @@ ((v,v),((v,v),((v,v),((v,v),(v,v))))) ] where v = 1 :: Int + w = 2 :: Int diff --git a/benchmarks/folds.hs b/benchmarks/folds.hs new file mode 100644 --- /dev/null +++ b/benchmarks/folds.hs @@ -0,0 +1,123 @@ +{-# 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 "sum" + [ bench "native" $ whnf V.sum v + , bench "each" $ whnf (sumOf each) 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 "sum" + [ bench "native" $ whnf U.sum u + , bench "each" $ whnf (sumOf each) 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 "sum" + [ bench "native" $ whnf sum l + , bench "each" $ whnf (sumOf each) 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 + diff --git a/benchmarks/plated.hs b/benchmarks/plated.hs --- a/benchmarks/plated.hs +++ b/benchmarks/plated.hs @@ -2,7 +2,8 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -import Control.Applicative +module Main (main) where + import Control.Lens import Control.DeepSeq import Criterion.Main @@ -14,7 +15,6 @@ import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly #endif import Generics.Deriving hiding (universe) -import GHC.Generics.Lens as Generic data Expr = Val !Int | Var String @@ -23,7 +23,7 @@ | Sub !Expr !Expr | Mul !Expr !Expr | Div !Expr !Expr - deriving (Eq,Show,Data,Typeable,Generic) + deriving (Eq,Show,Data,Generic) instance NFData Expr where rnf (Neg a) = rnf a @@ -59,11 +59,12 @@ main = defaultMain [ bench "universe" $ nf (map universe) testsExpr , bench "universeOf plate" $ nf (map (universeOf plate)) testsExpr - , bench "universeOf Generic.tinplate" $ nf (map (universeOf Generic.tinplate)) testsExpr , bench "universeOf Data.tinplate" $ nf (map (universeOf Data.tinplate)) testsExpr , bench "universeOf Data.template" $ nf (map (universeOf Data.template)) testsExpr , bench "universeOf Data.uniplate" $ nf (map (universeOf Data.uniplate)) testsExpr , bench "universeOf (cloneTraversal plate)" $ nf (map (universeOf (cloneTraversal plate))) testsExpr + , 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 @@ -72,3 +73,8 @@ 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)) diff --git a/benchmarks/traversals.hs b/benchmarks/traversals.hs new file mode 100644 --- /dev/null +++ b/benchmarks/traversals.hs @@ -0,0 +1,107 @@ +{-# 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 diff --git a/benchmarks/unsafe.hs b/benchmarks/unsafe.hs --- a/benchmarks/unsafe.hs +++ b/benchmarks/unsafe.hs @@ -1,21 +1,17 @@ {-# LANGUAGE BangPatterns #-} -module Main where +module Main (main) where import Control.Lens -import Control.Lens.Internal -import Control.Exception import Criterion.Main -import Criterion.Config - -import GHC.Exts +import Criterion.Types (Config(..)) overS :: ASetter s t a b -> (a -> b) -> s -> t -overS l f = runMutator . l (Mutator . f) +overS l f = runIdentity . l (Identity . f) {-# INLINE overS #-} mappedS :: ASetter [a] [b] a b -mappedS f = Mutator . map (runMutator . f) +mappedS f = Identity . map (runIdentity . f) {-# INLINE mappedS #-} overU :: ASetter s t a b -> (a -> b) -> s -> t @@ -53,11 +49,11 @@ --l = replicate n (); f = (\ _ -> ()) --l = replicate n (); f = (\ !_ -> ()) -- strange results --l = replicate n (); f = lazy (\_ -> ()) - defaultMainWith config (return ()) + 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 { cfgSamples = ljust 1000 } + config = defaultConfig { resamples = 1000 } diff --git a/benchmarks/zipper.hs b/benchmarks/zipper.hs deleted file mode 100644 --- a/benchmarks/zipper.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Main - ( main -- :: IO () - ) where - -import Control.Lens -import Criterion.Main - -main :: IO () -main = defaultMain - [ bgroup "rezip" - [ bench "rezip" $ nf tugAndRezip1 ['a'..'z'] - , bench "farthest leftward" $ nf tugAndRezip2 ['a'..'z'] - , bench "leftmost" $ nf tugAndRezip3 ['a'..'z'] - , bench "tugTo" $ nf tugAndRezip4 ['a'..'z'] - ] - , bgroup "zipper creation" - [ bench "over traverse id" $ nf (over traverse id) ['a'..'z'] - , bench "zipper" $ nf zipTraverseRezip ['a'..'z'] - ] - , bgroup "downward" - [ bench "downward _1" $ nf downwardAndRezip1 (['a'..'z'],['z'..'a']) - , bench "fromWithin" $ nf downwardAndRezip2 (['a'..'z'],['z'..'a']) - ] - ] - --- What's the fastest rezip of all? -tugAndRezip1, tugAndRezip2, tugAndRezip3 :: String -> String -tugAndRezip1 xs = zipntugs 25 xs & focus .~ 'a' & rezip -tugAndRezip2 xs = zipntugs 25 xs & focus .~ 'b' & farthest leftward & rezip -tugAndRezip3 xs = zipntugs 25 xs & focus .~ 'c' & leftmost & rezip -tugAndRezip4 xs = zipntugs 25 xs & focus .~ 'd' & tugTo 0 & rezip - -zipntugs i x = zipper x & fromWithin traverse & tugs rightward i - --- How fast is creating and destroying a zipper compared to --- a regular traversal? -zipTraverseRezip x = zipper x & fromWithin traverse & rezip - --- is 'downward' any faster than the composition of traverse? -downwardAndRezip1 :: (String, String) -> (String, String) -downwardAndRezip1 xs = - zipper xs & downward _1 & fromWithin traverse & focus .~ 'h' & rezip -downwardAndRezip2 :: (String, String) -> (String, String) -downwardAndRezip2 xs = - zipper xs & fromWithin (_1.traverse) & focus .~ 'g' & rezip diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: . + ./examples + ./lens-properties diff --git a/examples/.hlint.yaml b/examples/.hlint.yaml new file mode 100644 --- /dev/null +++ b/examples/.hlint.yaml @@ -0,0 +1,4 @@ +- arguments: [--cpp-ansi] + +- fixity: "infixr 9 ..." +- fixity: "infixl 1 &~" diff --git a/examples/Aeson.hs b/examples/Aeson.hs --- a/examples/Aeson.hs +++ b/examples/Aeson.hs @@ -11,14 +11,18 @@ import Control.Lens import Data.Aeson -import Data.ByteString.Lazy +import Data.ByteString.Lazy (ByteString) +-- $setup +-- >>> import Control.Lens + -- | -- >>> review aeson 5 -- "5" -- >>> [1,2,3]^.re aeson -- "[1,2,3]" --- >>> aeson.both +~ 2 $ (2,3)^.re aeson +-- >>> 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 diff --git a/examples/Brainfuck.hs b/examples/Brainfuck.hs deleted file mode 100644 --- a/examples/Brainfuck.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------ --- | --- Module : Brainfuck --- Copyright : (C) 2012 Edward Kmett, nand` --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : TH, Rank2, NoMonomorphismRestriction --- --- A simple interpreter for the esoteric programming language "Brainfuck" --- written using lenses and zippers. ------------------------------------------------------------------------------ -module Main where - -import Prelude hiding (Either(..)) - -import Control.Lens -import Control.Applicative -import Control.Monad.State -import Control.Monad.Writer - -import qualified Data.ByteString.Lazy as BS -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Word (Word8) - -import System.Environment (getArgs) -import System.IO - --- | Brainfuck is defined to have a memory of 30000 cells. -memoryCellNum :: Int -memoryCellNum = 30000 - --- Low level syntax form - -data Instr = Plus | Minus | Right | Left | Comma | Dot | Open | Close -type Code = [Instr] - -parse :: String -> Code -parse = mapMaybe (`lookup` symbols) - where symbols = [ ('+', Plus ), ('-', Minus), ('<', Left), ('>', Right) - , (',', Comma), ('.', Dot ), ('[', Open), (']', Close) ] - --- Higher level semantic graph - -data Program - = Succ Program | Pred Program -- Increment or decrement the current value - | Next Program | Prev Program -- Shift memory left or right - | Read Program | Write Program -- Input or output the current value - | Halt -- End execution - - -- Branching semantic, used for both sides of loops - | Branch { zero :: Program, nonzero :: Program } - -compile :: Code -> Program -compile = fst . bracket [] - -bracket :: [Program] -> Code -> (Program, [Program]) -bracket [] [] = (Halt, []) -bracket _ [] = error "Mismatched opening bracket" -bracket [] (Close:_) = error "Mismatched closing bracket" - --- Match a closing bracket: Pop a forward continuation, push backwards -bracket (c:cs) (Close : xs) = (Branch n c, n:bs) - where (n, bs) = bracket cs xs - --- Match an opening bracket: Pop a backwards continuation, push forwards -bracket cs (Open : xs) = (Branch b n, bs) - where (n, b:bs) = bracket (n:cs) xs - --- Match any other symbol in the trivial way -bracket cs (x:xs) = over _1 (f x) (bracket cs xs) - where - f Plus = Succ; f Minus = Pred - f Right = Next; f Left = Prev - f Comma = Read; f Dot = Write - --- * State/Writer-based interpreter - -type Cell = Word8 -type Input = [Cell] -type Output = [Cell] -type Memory = Top :>> [Cell] :>> Cell -- list zipper - -data MachineState = MachineState - { _input :: [Cell] - , _memory :: Memory } -makeLenses ''MachineState - -type Interpreter = StateT MachineState (Writer Output) () - --- | Initial memory configuration -initial :: Input -> MachineState -initial i = MachineState i (zipper (replicate memoryCellNum 0) & fromWithin traverse) - -interpret :: Input -> Program -> Output -interpret i = execWriter . flip execStateT (initial i) . run - --- | Evaluation function -run :: Program -> Interpreter -run Halt = return () -run (Succ n) = memory.focus += 1 >> run n -run (Pred n) = memory.focus -= 1 >> run n -run (Next n) = memory %= wrapRight >> run n -run (Prev n) = memory %= wrapLeft >> run n -run (Read n) = do - memory.focus <~ uses input head - input %= tail - run n -run (Write n) = do - x <- use (memory.focus) - tell [x] - run n -run (Branch z n) = do - c <- use (memory.focus) - run $ if c == 0 then z else n - --- | Zipper helpers -wrapRight, wrapLeft :: (a :>> b) -> (a :>> b) -wrapRight = liftM2 fromMaybe leftmost rightward -wrapLeft = liftM2 fromMaybe rightmost leftward - --- Main program action to actually run this stuff - -main :: IO () -main = do - as <- getArgs - case as of - -- STDIN is program - [ ] -> do - hSetBuffering stdin NoBuffering - hSetBuffering stdout NoBuffering - getContents >>= eval noInput - - -- STDIN is input - [f] -> join $ eval <$> getInput <*> readFile f - - -- Malformed command line - _ -> putStrLn "Usage: brainfuck [program]" - -eval :: Input -> String -> IO () -eval i = mapM_ putByte . interpret i . compile . parse - where putByte = BS.putStr . BS.pack . return - --- | EOF is represented as 0 -getInput :: IO Input -getInput = f <$> BS.getContents - where f s = BS.unpack s ++ repeat 0 - -noInput :: Input -noInput = repeat 0 diff --git a/examples/BrainfuckFinal.hs b/examples/BrainfuckFinal.hs deleted file mode 100644 --- a/examples/BrainfuckFinal.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------ --- | --- Module : BrainfuckFinal --- Copyright : (C) 2012 Edward Kmett, nand` --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : TH, Rank2, NoMonomorphismRestriction --- --- A simple interpreter for the esoteric programming language "Brainfuck" --- written using lenses and zippers. --- --- This version of the interpreter is 'finally encoded' without going through --- an AST. ------------------------------------------------------------------------------ -module Main where - -import Prelude hiding (Either(..)) - -import Control.Lens -import Control.Applicative -import Control.Monad.State -import Control.Monad.Writer - -import qualified Data.ByteString.Lazy as BS -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Word (Word8) - -import System.Environment (getArgs) -import System.IO - --- | Brainfuck is defined to have a memory of 30000 cells. -memoryCellNum :: Int -memoryCellNum = 30000 - --- * State/Writer-based interpreter - -type Cell = Word8 -type Input = [Cell] -type Output = [Cell] -type Memory = Top :>> [Cell] :>> Cell -- list zipper - -data MachineState = MachineState - { _input :: [Cell] - , _memory :: Memory } - -makeLenses ''MachineState - -type Program = StateT MachineState (Writer Output) () - -compile :: String -> Program -compile = fst . bracket [] - -branch :: Program -> Program -> Program -branch z n = do - c <- use (memory.focus) - if c == 0 then z else n - -bracket :: [Program] -> String -> (Program, [Program]) -bracket [] "" = (return () , []) -bracket _ "" = error "Mismatched opening bracket" -bracket [] (']':_) = error "Mismatched closing bracket" - --- Match a closing bracket: Pop a forward continuation, push backwards -bracket (c:cs) (']': xs) = (branch n c, n:bs) where - (n, bs) = bracket cs xs - --- Match an opening bracket: Pop a backwards continuation, push forwards -bracket cs ('[': xs) = (branch b n, bs) where - (n, b:bs) = bracket (n:cs) xs - --- Match any other symbol in the trivial way -bracket cs (x:xs) = over _1 (f x >>) (bracket cs xs) where - f '+' = memory.focus += 1 - f '-' = memory.focus -= 1 - f '>' = memory %= wrapRight - f '<' = memory %= wrapLeft - f ',' = do - memory.focus <~ uses input head - input %= tail - f '.' = do - x <- use (memory.focus) - tell [x] - f _ = return () - --- | Initial memory configuration -initial :: Input -> MachineState -initial i = MachineState i (zipper (replicate memoryCellNum 0) & fromWithin traverse) - -interpret :: Input -> Program -> Output -interpret i = execWriter . flip execStateT (initial i) - --- | Zipper helpers -wrapRight, wrapLeft :: (a :>> b) -> (a :>> b) -wrapRight = liftM2 fromMaybe leftmost rightward -wrapLeft = liftM2 fromMaybe rightmost leftward - --- Main program action to actually run this stuff - -main :: IO () -main = do - as <- getArgs - case as of - -- STDIN is program - [ ] -> do - hSetBuffering stdin NoBuffering - hSetBuffering stdout NoBuffering - getContents >>= eval noInput - - -- STDIN is input - [f] -> join $ eval <$> getInput <*> readFile f - - -- Malformed command line - _ -> putStrLn "Usage: brainfuck [program]" - -eval :: Input -> String -> IO () -eval i = mapM_ putByte . interpret i . compile - where putByte = BS.putStr . BS.pack . return - --- | EOF is represented as 0 -getInput :: IO Input -getInput = f <$> BS.getContents - where f s = BS.unpack s ++ repeat 0 - -noInput :: Input -noInput = repeat 0 diff --git a/examples/Plates.hs b/examples/Plates.hs --- a/examples/Plates.hs +++ b/examples/Plates.hs @@ -1,23 +1,23 @@ {-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} -import Control.Applicative +module Plates where + import Control.Lens import GHC.Generics import Data.Data -import Data.Data.Lens -data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) -data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) +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 f (Var x ) = pure (Var x) + 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 f (Sel xs) = pure (Sel xs) - plate f (Let x y) = pure (Let x y) + 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 diff --git a/examples/Pong.hs b/examples/Pong.hs --- a/examples/Pong.hs +++ b/examples/Pong.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Main --- Copyright : (C) 2012 Edward Kmett, nand` +-- Copyright : (C) 2012 Edward Kmett, Niklas Haas -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -12,23 +12,30 @@ ----------------------------------------------------------------------------- module Main where -import Control.Applicative ((<$>), (<*>)) -import Control.Lens +import Control.Lens hiding ((:>), at) import Control.Monad.State (State, execState, get) import Control.Monad (when) -import Data.Set (Set, member, empty, insert, delete) +import Data.Set (Set, empty) +import Data.Stream.Infinite (Stream(..)) -import Graphics.Gloss +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 @@ -37,6 +44,8 @@ paddleWidth = 0.02 paddleHeight = 0.3 paddleSpeed = 1 + +textSize :: Float textSize = 0.001 -- Pure data type for representing the game state @@ -47,7 +56,7 @@ , _paddle1 :: Float , _paddle2 :: Float , _score :: (Int, Int) - , _vectors :: [Vector] + , _vectors :: Stream Vector -- Since gloss doesn't cover this, we store the set of pressed keys , _keys :: Set Key @@ -57,11 +66,14 @@ 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) [] empty +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 @@ -100,7 +112,7 @@ updateBall :: Float -> State Pong () updateBall time = do (u, v) <- use ballSpeed - ballPos += (time * u, time * v) + ballPos %= (Pt.+ (time * u, time * v)) -- Make sure it doesn't leave the playing area ballPos.both %= clamp ballRadius @@ -173,7 +185,7 @@ -- Retrieve a speed from the list, dropping it in the process nextSpeed :: State Pong Vector nextSpeed = do - v:vs <- use vectors + v:>vs <- use vectors vectors .= vs return v @@ -191,7 +203,7 @@ ] where paddleX = 1 + paddleWidth/2 - p `at` (x,y) = translate x y p; infixr 1 `at` + po `at` (x,y) = translate x y po; infixr 1 `at` drawPaddle :: Picture drawPaddle = rectangleSolid paddleWidth paddleHeight @@ -210,8 +222,9 @@ -- The main program action +main :: IO () main = do - v:vs <- startingSpeeds + v:>vs <- startingSpeeds let world = ballSpeed .~ v $ vectors .~ vs $ initial play display backColor fps world draw handle update @@ -222,12 +235,16 @@ -- Generate the random list of starting speeds -startingSpeeds :: IO [Vector] +startingSpeeds :: IO (Stream Vector) startingSpeeds = do rs <- randomRs (-initialSpeed, initialSpeed) <$> newStdGen - return . interleave $ filter ((> 0.2) . abs) rs + 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") diff --git a/examples/Turtle.hs b/examples/Turtle.hs --- a/examples/Turtle.hs +++ b/examples/Turtle.hs @@ -11,7 +11,7 @@ module Turtle where import Control.Lens -import Data.Default +import Data.Default.Class data Point = Point { __x, __y :: Double diff --git a/examples/bf-examples/99bottles.bf b/examples/bf-examples/99bottles.bf deleted file mode 100644 --- a/examples/bf-examples/99bottles.bf +++ /dev/null @@ -1,60 +0,0 @@ -99 Bottles of Beer in Urban Mueller's BrainF*** (The actual -name is impolite) - -by Ben Olmstead - -ANSI C interpreter available on the internet; due to -constraints in comments the address below needs to have the -stuff in parenthesis replaced with the appropriate symbol: - -http://www(dot)cats(dash)eye(dot)com/cet/soft/lang/bf/ - -Believe it or not this language is indeed Turing complete! -Combines the speed of BASIC with the ease of INTERCAL and -the readability of an IOCCC entry! - ->+++++++++[<+++++++++++>-]<[>[-]>[-]<<[>+>+<<-]>>[<<+>>-]>>> -[-]<<<+++++++++<[>>>+<<[>+>[-]<<-]>[<+>-]>[<<++++++++++>>>+< --]<<-<-]+++++++++>[<->-]>>+>[<[-]<<+>>>-]>[-]+<<[>+>-<<-]<<< -[>>+>+<<<-]>>>[<<<+>>>-]>[<+>-]<<-[>[-]<[-]]>>+<[>[-]<-]<+++ -+++++[<++++++<++++++>>-]>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>- -]<<<<<<.>>[-]>[-]++++[<++++++++>-]<.>++++[<++++++++>-]<++.>+ -++++[<+++++++++>-]<.><+++++..--------.-------.>>[>>+>+<<<-]> ->>[<<<+>>>-]<[<<<<++++++++++++++.>>>>-]<<<<[-]>++++[<+++++++ -+>-]<.>+++++++++[<+++++++++>-]<--.---------.>+++++++[<------ ----->-]<.>++++++[<+++++++++++>-]<.+++..+++++++++++++.>++++++ -++[<---------->-]<--.>+++++++++[<+++++++++>-]<--.-.>++++++++ -[<---------->-]<++.>++++++++[<++++++++++>-]<++++.----------- --.---.>+++++++[<---------->-]<+.>++++++++[<+++++++++++>-]<-. ->++[<----------->-]<.+++++++++++..>+++++++++[<---------->-]< ------.---.>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>>+++ -+[<++++++>-]<--.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<. -><+++++..--------.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++ -++++++++++++.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<++ -+++++++>-]<--.---------.>+++++++[<---------->-]<.>++++++[<++ -+++++++++>-]<.+++..+++++++++++++.>++++++++++[<---------->-]< --.---.>+++++++[<++++++++++>-]<++++.+++++++++++++.++++++++++. -------.>+++++++[<---------->-]<+.>++++++++[<++++++++++>-]<-. --.---------.>+++++++[<---------->-]<+.>+++++++[<++++++++++>- -]<--.+++++++++++.++++++++.---------.>++++++++[<---------->-] -<++.>+++++[<+++++++++++++>-]<.+++++++++++++.----------.>++++ -+++[<---------->-]<++.>++++++++[<++++++++++>-]<.>+++[<-----> --]<.>+++[<++++++>-]<..>+++++++++[<--------->-]<--.>+++++++[< -++++++++++>-]<+++.+++++++++++.>++++++++[<----------->-]<++++ -.>+++++[<+++++++++++++>-]<.>+++[<++++++>-]<-.---.++++++.---- ----.----------.>++++++++[<----------->-]<+.---.[-]<<<->[-]>[ --]<<[>+>+<<-]>>[<<+>>-]>>>[-]<<<+++++++++<[>>>+<<[>+>[-]<<-] ->[<+>-]>[<<++++++++++>>>+<-]<<-<-]+++++++++>[<->-]>>+>[<[-]< -<+>>>-]>[-]+<<[>+>-<<-]<<<[>>+>+<<<-]>>>[<<<+>>>-]<>>[<+>-]< -<-[>[-]<[-]]>>+<[>[-]<-]<++++++++[<++++++<++++++>>-]>>>[>+>+ -<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>[-]>[-]++++[<++++++++> --]<.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<.><+++++..--- ------.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++++++++++++++ -.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<+++++++++>-]<- --.---------.>+++++++[<---------->-]<.>++++++[<+++++++++++>-] -<.+++..+++++++++++++.>++++++++[<---------->-]<--.>+++++++++[ -<+++++++++>-]<--.-.>++++++++[<---------->-]<++.>++++++++[<++ -++++++++>-]<++++.------------.---.>+++++++[<---------->-]<+. ->++++++++[<+++++++++++>-]<-.>++[<----------->-]<.+++++++++++ -..>+++++++++[<---------->-]<-----.---.+++.---.[-]<<<] - diff --git a/examples/bf-examples/brainfuck.bf b/examples/bf-examples/brainfuck.bf deleted file mode 100644 --- a/examples/bf-examples/brainfuck.bf +++ /dev/null @@ -1,6 +0,0 @@ ->>>+[[-]>>[-]++>+>+++++++[<++++>>++<-]++>>+>+>+++++[>++>++++++<<-]+>>>,<++[[>[ -->>]<[>>]<<-]<[<]<+>>[>]>[<+>-[[<+>-]>]<[[[-]<]++<-[<+++++++++>[<->-]>>]>>]]<< -]<]<[[<]>[[>]>>[>>]+[<<]<[<]<+>>-]>[>]+[->>]<<<<[[<<]<[<]+<<[+>+<<-[>-->+<<-[> -+<[>>+<<-]]]>[<+>-]<]++>>-->[>]>>[>>]]<<[>>+<[[<]<]>[[<<]<[<]+[-<+>>-[<<+>++>- -[<->[<<+>>-]]]<[>+<-]>]>[>]>]>[>>]>>]<<[>>+>>+>>]<<[->>>>>>>>]<<[>.>>>>>>>]<<[ ->->>>>>]<<[>,>>>]<<[>+>]<<[+<<]<] diff --git a/examples/bf-examples/cat.bf b/examples/bf-examples/cat.bf deleted file mode 100644 --- a/examples/bf-examples/cat.bf +++ /dev/null @@ -1,1 +0,0 @@ -,[.,] diff --git a/examples/bf-examples/helloworld.bf b/examples/bf-examples/helloworld.bf deleted file mode 100644 --- a/examples/bf-examples/helloworld.bf +++ /dev/null @@ -1,23 +0,0 @@ -Source: Wikipedia - -+++++ +++++ initialize counter (cell #0) to 10 -[ use loop to set the next four cells to 70/100/30/10 - > +++++ ++ add 7 to cell #1 - > +++++ +++++ add 10 to cell #2 - > +++ add 3 to cell #3 - > + add 1 to cell #4 - <<<< - decrement counter (cell #0) -] -> ++ . print 'H' -> + . print 'e' -+++++ ++ . print 'l' -. print 'l' -+++ . print 'o' -> ++ . print ' ' -<< +++++ +++++ +++++ . print 'W' -> . print 'o' -+++ . print 'r' ------ - . print 'l' ------ --- . print 'd' -> + . print '!' -> . print '\n' diff --git a/examples/bf-examples/rot13.bf b/examples/bf-examples/rot13.bf deleted file mode 100644 --- a/examples/bf-examples/rot13.bf +++ /dev/null @@ -1,23 +0,0 @@ -, -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>++++++++++++++<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>>+++++[<----->-]<<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>++++++++++++++<- -[>+<-[>+<-[>+<-[>+<-[>+<- -[>++++++++++++++<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>>+++++[<----->-]<<- -[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<- -[>++++++++++++++<- -[>+<-]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] -]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]>.[-]<,] - -of course any function char f(char) can be made easily on the same principle - -[Daniel B Cristofani (cristofdathevanetdotcom) -http://www.hevanet.com/cristofd/brainfuck/] diff --git a/examples/bf-examples/triangle.bf b/examples/bf-examples/triangle.bf deleted file mode 100644 --- a/examples/bf-examples/triangle.bf +++ /dev/null @@ -1,33 +0,0 @@ -[ This program prints Sierpinski triangle on 80-column display. ] - > - + + - + + - [ < + + - + + - + + + + - > - ] > - + + + + + + + + - [ > - + + + + - < - ] > - > + + > > > + > - > > + < - < < < < < < < < - < [ - [ - > + < - ] > [ - < + > > > . < < ] > > > - [ [ - - > + + - + + + + - + + [ > + + + + - < - ] > - . < < [ - > + < - ] + > [ - > + + - + + + + + + + + < < + > ] > . [ - - ] > ] - ] + < < < [ - [ - - > + < ] + > [ - - < + > > > - [ - > + < ] + + > - [ - < - > ] < < - < ] < < < < ] + + + + + + + + + - + . + + + . [ - ] < ] + + + + + - * * * * * M a d e * B y : * N Y Y R I K K I * 2 0 0 2 * * * * * diff --git a/examples/lens-examples.cabal b/examples/lens-examples.cabal --- a/examples/lens-examples.cabal +++ b/examples/lens-examples.cabal @@ -2,65 +2,68 @@ category: Data, Lenses version: 0.1 license: BSD3 -cabal-version: >= 1.8 +cabal-version: >= 1.10 license-file: LICENSE -author: nand +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: Pong Example +description: Lenses, Folds and Traversals + . + Pong Example build-type: Simple -tested-with: GHC == 7.4.1 +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.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 source-repository head type: git - location: git://github.com/ekmett/lens.git + location: https://github.com/ekmett/lens.git flag pong default: True -flag brainfuck - default: True +library + exposed-modules: + Aeson + Plates + Turtle + build-depends: + aeson, + base >= 4.9 && < 5, + bytestring >= 0.9.1.10 && < 0.13, + data-default-class, + lens + default-language: Haskell2010 + ghc-options: -Wall executable lens-pong if !flag(pong) buildable: False build-depends: - base, - containers >= 0.4 && < 0.6, - gloss == 1.7.*, + base >= 4.9 && < 5, + containers >= 0.4 && < 0.9, + gloss >= 1.12 && < 1.14, lens, - mtl >= 2.0.1 && < 2.2, - random == 1.0.* + mtl >= 2.0.1 && < 2.4, + random >= 1.0 && < 1.4, + streams >= 3.3 && < 4 main-is: Pong.hs - -executable lens-brainfuck - if !flag(brainfuck) - buildable: False - - build-depends: - base, - lens, - free >= 3.0, - bytestring, - mtl >= 2.0.1 && < 2.2, - streams >= 3.0 - main-is: Brainfuck.hs - -executable lens-brainfuck-final - if !flag(brainfuck) - buildable: False - - build-depends: - base, - lens, - free >= 3.0, - bytestring, - mtl >= 2.0.1 && < 2.2, - streams >= 3.0 - main-is: BrainfuckFinal.hs + default-language: Haskell2010 + ghc-options: -Wall diff --git a/images/Hierarchy.png b/images/Hierarchy.png Binary files a/images/Hierarchy.png and b/images/Hierarchy.png differ diff --git a/images/overview.png b/images/overview.png Binary files a/images/overview.png and b/images/overview.png differ diff --git a/include/lens-common.h b/include/lens-common.h new file mode 100644 --- /dev/null +++ b/include/lens-common.h @@ -0,0 +1,26 @@ +#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 diff --git a/lens-properties/.hlint.yaml b/lens-properties/.hlint.yaml new file mode 100644 --- /dev/null +++ b/lens-properties/.hlint.yaml @@ -0,0 +1,4 @@ +- arguments: [--cpp-ansi] +- ignore: { name: Use camelCase } +- fixity: "infixr 9 ..." +- fixity: "infixl 1 &~" diff --git a/lens-properties/CHANGELOG.markdown b/lens-properties/CHANGELOG.markdown --- a/lens-properties/CHANGELOG.markdown +++ b/lens-properties/CHANGELOG.markdown @@ -1,3 +1,11 @@ +next [????.??.??] +----------------- +* Drop support for GHC 7.10 and older. + +4.11.1 +------ +* Update version bounds. + 4.0 --- diff --git a/lens-properties/lens-properties.cabal b/lens-properties/lens-properties.cabal new file mode 100644 --- /dev/null +++ b/lens-properties/lens-properties.cabal @@ -0,0 +1,51 @@ +name: 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.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 + +extra-source-files: + .hlint.yaml + CHANGELOG.markdown + +source-repository head + type: git + location: https://github.com/ekmett/lens.git + +library + build-depends: + base >= 4.9 && < 5, + lens >= 4 && < 6, + QuickCheck >= 2.4 && < 2.18, + transformers >= 0.2 && < 0.7 + + exposed-modules: + Control.Lens.Properties + + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 diff --git a/lens-properties/src/Control/Lens/Properties.hs b/lens-properties/src/Control/Lens/Properties.hs --- a/lens-properties/src/Control/Lens/Properties.hs +++ b/lens-properties/src/Control/Lens/Properties.hs @@ -12,11 +12,9 @@ , isPrism ) where -import Control.Applicative import Control.Lens import Data.Functor.Compose import Test.QuickCheck -import Test.QuickCheck.Function -------------------------------------------------------------------------------- -- | A 'Setter' is only legal if the following 3 laws hold: @@ -27,7 +25,7 @@ -- -- 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) - => Simple Setter s a -> Property + => Setter' s a -> Property isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l @@ -39,13 +37,13 @@ -- -- 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) - => Simple Traversal s a -> Property + => Traversal' s a -> Property isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l .&. do as <- arbitrary bs <- arbitrary t <- arbitrary - property $ traverse_compose l (\x -> as++[x]++bs) - (\x -> if t then Just x else Nothing) + return $ traverse_compose l (\x -> as++[x]++bs) + (\x -> if t then Just x else Nothing) -------------------------------------------------------------------------------- @@ -58,50 +56,50 @@ -- -- 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) - => Simple Lens s a -> Property + => 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) - => Simple Iso s a -> Property + => Iso' s a -> Property isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) -------------------------------------------------------------------------------- isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) - => Simple Prism s a -> Property + => Prism' s a -> Property isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l -------------------------------------------------------------------------------- -- The first setter law: -setter_id :: Eq s => Simple Setter s a -> s -> Bool +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 => Simple Setter s a -> s -> Fun a a -> Fun a a -> Bool +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 => Simple Lens s a -> s -> Bool +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 => Simple Lens s a -> s -> a -> Bool +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 => Simple Setter s a -> s -> a -> a -> Bool +setter_set_set :: Eq s => Setter' s a -> s -> a -> a -> Bool setter_set_set l s a b = set l b (set l a s) == set l b s -iso_hither :: Eq s => Simple AnIso s a -> s -> Bool +iso_hither :: Eq s => AnIso' s a -> s -> Bool iso_hither l s = s ^.cloneIso l.from l == s -iso_yon :: Eq a => Simple AnIso s a -> a -> Bool +iso_yon :: Eq a => AnIso' s a -> a -> Bool iso_yon l a = a^.from l.cloneIso l == a -prism_yin :: Eq a => Simple Prism s a -> a -> Bool +prism_yin :: Eq a => Prism' s a -> a -> Bool prism_yin l a = preview l (review l a) == Just a -prism_yang :: Eq s => Simple Prism s a -> s -> Bool +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 @@ -114,5 +112,5 @@ traverse_pureList = traverse_pure traverse_compose :: (Applicative f, Applicative g, Eq (f (g s))) - => Simple Traversal s a -> (a -> g a) -> (a -> f a) -> s -> Bool + => 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 diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,18 +1,31 @@ name: lens category: Data, Lenses, Generics -version: 4.1.2.1 -license: BSD3 -cabal-version: >= 1.8 +version: 5.3.6 +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-2014 Edward A. Kmett -build-type: Custom +copyright: Copyright (C) 2012-2016 Edward A. Kmett +build-type: Simple -- build-tools: cpphs -tested-with: GHC == 7.6.3 +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.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types @@ -25,7 +38,7 @@ . 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 . + 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 . . @@ -41,9 +54,7 @@ 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. @@ -88,30 +99,31 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). extra-source-files: - .travis.yml - .ghci .gitignore + .hlint.yaml .vim.custom + cabal.project examples/LICENSE examples/lens-examples.cabal examples/*.hs examples/*.lhs - examples/bf-examples/*.bf - images/*.png + examples/.hlint.yaml + include/*.h + lens-properties/.hlint.yaml lens-properties/CHANGELOG.markdown lens-properties/LICENSE lens-properties/Setup.hs - travis/cabal-apt-install - travis/config - HLint.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: git://github.com/ekmett/lens.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. @@ -131,26 +143,11 @@ manual: True default: True --- Some 7.6.1-rc1 users report their TH still uses old style inline pragmas. This lets them turn on inlining. -flag old-inline-pragmas - default: False - manual: True - -- Make the test suites dump their template-haskell splices. flag dump-splices default: False manual: True --- You can disable the hlint test suite with -f-test-hlint -flag test-hlint - default: True - manual: True - --- You can disable the doctests test suite with -f-test-doctests -flag test-doctests - default: True - manual: True - -- You can disable the hunit test suite with -f-test-hunit flag test-hunit default: True @@ -161,9 +158,8 @@ default: True manual: True --- Disallow unsafeCoerce -flag safe - default: False +flag test-templates + default: True manual: True -- Assert that we are trustworthy when we can @@ -171,10 +167,6 @@ default: True manual: True -flag lib-Werror - default: False - manual: True - -- Attempt a parallel build with GHC 7.8 flag j default: False @@ -182,45 +174,45 @@ library build-depends: - aeson >= 0.7 && < 0.8, - array >= 0.3.0.2 && < 0.6, - base >= 4.3 && < 5, - bifunctors >= 4 && < 5, - bytestring >= 0.9.1.10 && < 0.11, - comonad >= 4 && < 5, - contravariant >= 0.3 && < 1, - containers >= 0.4.0 && < 0.6, - distributive >= 0.3 && < 1, - filepath >= 1.2.0.0 && < 1.4, - free >= 4 && < 5, - ghc-prim, - hashable >= 1.1.2.3 && < 1.3, - exceptions >= 0.1.1 && < 1, - mtl >= 2.0.1 && < 2.2, - parallel >= 3.1.0.1 && < 3.3, - primitive >= 0.4.0.1 && < 0.6, - profunctors >= 4 && < 5, - reflection >= 1.1.6 && < 2, - scientific >= 0.2 && < 0.4, - semigroupoids >= 4 && < 5, - semigroups >= 0.8.4 && < 1, - split >= 0.2 && < 0.3, - tagged >= 0.4.4 && < 1, - template-haskell >= 2.4 && < 2.11, - text >= 0.11 && < 1.2, - transformers >= 0.2 && < 0.4, - transformers-compat >= 0.1 && < 1, - unordered-containers >= 0.2 && < 0.3, - utf8-string >= 0.3.7 && < 0.4, - vector >= 0.9 && < 0.11, - void >= 0.5 && < 1, - zlib >= 0.5.4 && < 0.6 + 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.9, + contravariant >= 1.4 && < 2, + distributive >= 0.5.1 && < 1, + exceptions >= 0.8.2.1 && < 1, + filepath >= 1.2.0.0 && < 1.6, + free >= 5.1.5 && < 6, + hashable >= 1.2.7.0 && < 1.6, + indexed-traversable >= 0.1 && < 0.2, + indexed-traversable-instances >= 0.1 && < 0.2, + kan-extensions >= 5 && < 6, + mtl >= 2.2.1 && < 2.4, + parallel >= 3.2.1.0 && < 3.4, + profunctors >= 5.5.2 && < 6, + reflection >= 2.1 && < 3, + semigroupoids >= 5.0.1 && < 7, + strict >= 0.4 && < 0.6, + tagged >= 0.8.6 && < 1, + template-haskell >= 2.11.1.0 && < 2.25, + text >= 1.2.3.0 && < 2.2, + th-abstraction >= 0.4.1 && < 0.8, + these >= 1.1.1.1 && < 1.3, + transformers >= 0.5.0.0 && < 0.7, + 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: - Codec.Compression.Zlib.Lens - Control.Exception.Lens Control.Lens - Control.Lens.Action + + exposed-modules: + Control.Exception.Lens Control.Lens.At Control.Lens.Combinators Control.Lens.Cons @@ -232,21 +224,25 @@ Control.Lens.Getter Control.Lens.Indexed Control.Lens.Internal - Control.Lens.Internal.Action Control.Lens.Internal.Bazaar Control.Lens.Internal.ByteString Control.Lens.Internal.Context + Control.Lens.Internal.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.Reflection + Control.Lens.Internal.Profunctor Control.Lens.Internal.Review Control.Lens.Internal.Setter Control.Lens.Internal.TH @@ -254,10 +250,10 @@ Control.Lens.Iso Control.Lens.Lens Control.Lens.Level - Control.Lens.Loupe Control.Lens.Operators Control.Lens.Plated Control.Lens.Prism + Control.Lens.Profunctor Control.Lens.Reified Control.Lens.Review Control.Lens.Setter @@ -265,13 +261,12 @@ Control.Lens.Traversal Control.Lens.Tuple Control.Lens.Type + Control.Lens.Unsound Control.Lens.Wrapped Control.Lens.Zoom Control.Monad.Error.Lens - Control.Monad.Primitive.Lens Control.Parallel.Strategies.Lens Control.Seq.Lens - Data.Aeson.Lens Data.Array.Lens Data.Bits.Lens Data.ByteString.Lens @@ -283,7 +278,6 @@ Data.HashSet.Lens Data.IntSet.Lens Data.List.Lens - Data.List.Split.Lens Data.Map.Lens Data.Sequence.Lens Data.Set.Lens @@ -294,58 +288,63 @@ Data.Typeable.Lens Data.Vector.Lens Data.Vector.Generic.Lens - Generics.Deriving.Lens GHC.Generics.Lens System.Exit.Lens System.FilePath.Lens System.IO.Error.Lens Language.Haskell.TH.Lens Numeric.Lens + Numeric.Natural.Lens other-modules: - Control.Lens.Internal.TupleIxedTH - - cpp-options: -traditional - - if flag(safe) - cpp-options: -DSAFE=1 + Control.Lens.Internal.Prelude - if flag(trustworthy) && impl(ghc>=7.2) + if flag(trustworthy) && impl(ghc) other-extensions: Trustworthy cpp-options: -DTRUSTWORTHY=1 - if flag(old-inline-pragmas) && impl(ghc>=7.6.0.20120810) - cpp-options: -DOLD_INLINE_PRAGMAS=1 - if flag(inlining) cpp-options: -DINLINING - if flag(lib-Werror) - ghc-options: -Werror - - if impl(ghc<7.4) - ghc-options: -fno-spec-constr-count - - if flag(j) && impl(ghc>=7.8) + if flag(j) ghc-options: -j4 - ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10 + 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 - build-depends: base, lens + other-modules: + BigRecord + T799 + T917 + T972 + if impl(ghc >= 9.2) + other-modules: + T1024 ghc-options: -Wall -threaded hs-source-dirs: tests + default-language: Haskell2010 if flag(dump-splices) ghc-options: -ddump-splices - if impl(ghc<7.6.1) - ghc-options: -Werror - + if !flag(test-templates) + buildable: False + else + build-depends: base, lens -- Verify the properties of lenses with QuickCheck test-suite properties @@ -353,27 +352,29 @@ main-is: properties.hs other-modules: Control.Lens.Properties - ghc-options: -w -threaded -rtsopts -with-rtsopts=-N + 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, - test-framework-th >= 0.2, + QuickCheck >= 2.4, + tasty >= 1.4 && < 1.6, + tasty-quickcheck >= 0.10 && < 0.12, transformers test-suite hunit type: exitcode-stdio-1.0 main-is: hunit.hs - ghc-options: -w -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests + default-language: Haskell2010 if !flag(test-hunit) buildable: False @@ -381,64 +382,32 @@ build-depends: base, containers, - HUnit >= 1.2, lens, mtl, - test-framework >= 0.6, - test-framework-hunit >= 0.2, - test-framework-th >= 0.2 - --- Verify the results of the examples -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - ghc-options: -Wall -threaded - hs-source-dirs: tests - - if !flag(test-doctests) - buildable: False - else - build-depends: - base, - bytestring, - containers, - directory >= 1.0, - deepseq, - doctest >= 0.9.1, - filepath, - generic-deriving, - mtl, - nats, - parallel, - semigroups >= 0.9, - simple-reflect >= 0.3.1, - split, text, - unordered-containers, - vector - - if impl(ghc<7.6.1) - ghc-options: -Werror + bytestring, + tasty >= 1.4 && < 1.6, + tasty-hunit >= 0.10 && < 0.11 -test-suite hlint - type: exitcode-stdio-1.0 - main-is: hlint.hs - ghc-options: -w -threaded -rtsopts -with-rtsopts=-N - hs-source-dirs: tests +-- 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 - if !flag(test-hlint) - buildable: False - else - build-depends: - base, - hlint >= 1.7 + build-depends: base <5, 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 + 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, comonad, @@ -454,47 +423,63 @@ -- Benchmarking alongside variants benchmark alongside - type: exitcode-stdio-1.0 - main-is: alongside.hs - ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields - hs-source-dirs: benchmarks + 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, - comonads-fd, + comonad >= 4, criterion, deepseq, lens, transformers --- Benchmarking unsafe implementation strategies -benchmark unsafe - type: exitcode-stdio-1.0 - main-is: unsafe.hs - ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields - hs-source-dirs: benchmarks +-- 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, - comonad, - comonads-fd, criterion, - deepseq, - generic-deriving, - lens, - transformers - + containers, + bytestring, + unordered-containers, + vector, + lens --- Benchmarking zipper usage -benchmark zipper - type: exitcode-stdio-1.0 - main-is: zipper.hs - ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields - hs-source-dirs: benchmarks +-- 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, - comonad, - comonads-fd, 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, diff --git a/src/Codec/Compression/Zlib/Lens.hs b/src/Codec/Compression/Zlib/Lens.hs deleted file mode 100644 --- a/src/Codec/Compression/Zlib/Lens.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------ --- | --- Module : Codec.Compression.Zlib.Lens --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- @lens@ support for the @zlib@ library ----------------------------------------------------------------------------- -module Codec.Compression.Zlib.Lens - ( -- * High-Level API - gzipped, - zlibbed, - deflated, - compressed, - Format, - gzip, - zlib, - deflate, - -- * Low-Level API - zlibbed', - gzipped', - deflated', - compressed', - Params, - defaultParams, - levelC, - methodC, - windowBitsC, - windowBitsD, - memoryLevelC, - strategyC, - bufferSizeC, - bufferSizeD, - dictionary, - CompressionLevel, - defaultCompression, - noCompression, - bestSpeed, - bestCompression, - compressionLevel, - Method, - deflateMethod, - WindowBits, - defaultWindowBits, - windowBits, - MemoryLevel, - defaultMemoryLevel, - minMemoryLevel, - maxMemoryLevel, - memoryLevel, - CompressionStrategy, - defaultStrategy, - filteredStrategy, - huffmanOnlyStrategy - ) where - -import Control.Applicative -import Codec.Compression.Zlib.Internal -import Control.Lens -import qualified Data.ByteString as S (ByteString) -import qualified Data.ByteString.Lazy as L (ByteString) - --- | --- The 'zlib' compression format. -zlib :: Format -zlib = zlibFormat -{-# INLINE zlib #-} - --- | --- The 'gzip' compression format. -gzip :: Format -gzip = gzipFormat -{-# INLINE gzip #-} - --- | --- The 'deflate' compression format. -deflate :: Format -deflate = rawFormat -{-# INLINE deflate #-} - --- | --- Compresses a 'L.ByteString' using the 'gzip' compression format. --- --- @ --- 'gzipped' = 'compressed' 'gzip' --- 'gzipped' = 'gzipped'' 'defaultParams' --- @ -gzipped :: Iso' L.ByteString L.ByteString -gzipped = compressed gzip -{-# INLINE gzipped #-} - --- | --- Compresses a 'L.ByteString' using the 'zlib' compression format. --- --- @ --- 'zlibbed' = 'compressed' 'zlib' --- 'zlibbed' = 'zlibbed\'' 'defaultParams' --- @ -zlibbed :: Iso' L.ByteString L.ByteString -zlibbed = compressed zlib -{-# INLINE zlibbed #-} - --- | --- Compresses a 'L.ByteString' using the 'deflate' compression format. --- --- @ --- 'deflated' = 'compressed' 'deflate' --- 'deflated' = 'deflated'' 'defaultParams' --- @ -deflated :: Iso' L.ByteString L.ByteString -deflated = compressed deflate -{-# INLINE deflated #-} - --- | --- Compresses a 'L.ByteString' using the given compression format. --- --- @ --- 'compressed' fmt = 'compressed'' fmt 'defaultParams' --- @ -compressed :: Format -> Iso' L.ByteString L.ByteString -compressed fmt = compressed' fmt defaultParams -{-# INLINE compressed #-} - --- | --- Compresses a 'L.ByteString' using the 'gzip' compression format and the given advanced parameters. --- --- @ --- 'gzipped' = 'compressed' 'gzip' --- 'gzipped' = 'gzipped'' 'defaultParams' --- @ -gzipped' :: Params -> Iso' L.ByteString L.ByteString -gzipped' = compressed' gzip -{-# INLINE gzipped' #-} - --- | --- Compresses a 'L.ByteString' using the 'zlib' compression format and the given advanced parameters. --- --- @ --- 'zlibbed' = 'compressed' 'zlib' --- 'zlibbed' = 'zlibbed'' 'defaultParams' --- @ -zlibbed' :: Params -> Iso' L.ByteString L.ByteString -zlibbed' = compressed' zlib -{-# INLINE zlibbed' #-} - --- | --- Compresses a 'L.ByteString' using the 'deflate' compression format and the given advanced parameters. --- --- @ --- 'deflated' = 'compressed' 'deflate' --- 'deflated' = 'deflated'' 'defaultParams' --- @ -deflated' :: Params -> Iso' L.ByteString L.ByteString -deflated' = compressed' deflate -{-# INLINE deflated' #-} - --- | --- Compresses a 'L.ByteString' using the given compression format and the given advanced parameters. -compressed' :: Format -> Params -> Iso' L.ByteString L.ByteString -compressed' fmt (Params c d) = iso (compress fmt c) (decompress fmt d) -{-# INLINE compressed' #-} - --- | --- The advanced parameters needed by 'gzipped'', 'zlibbed'', 'deflated'', and 'compressed''. --- --- Use 'defaultParams' and the provided 'Lens'es to construct custom 'Params'. -data Params = Params !CompressParams !DecompressParams - --- | --- The default advanced parameters for compression and decompression. -defaultParams :: Params -defaultParams = Params defaultCompressParams defaultDecompressParams -{-# INLINE defaultParams #-} - --- | --- The compression level. -levelC :: Lens' Params CompressionLevel -levelC = \ f (Params c d) -> (\l -> Params (c {compressLevel = l}) d) <$> f (compressLevel c) -{-# INLINE levelC #-} - --- | --- The compression method. -methodC :: Lens' Params Method -methodC = \ f (Params c d) -> (\m -> Params (c {compressMethod = m}) d) <$> f (compressMethod c) -{-# INLINE methodC #-} - --- | --- The number of bits in the compression window. -windowBitsC :: Lens' Params WindowBits -windowBitsC = \ f (Params c d) -> (\wb -> Params (c {compressWindowBits = wb}) d) <$> f (compressWindowBits c) -{-# INLINE windowBitsC #-} - --- | --- The number of bits in the decompression window. -windowBitsD :: Lens' Params WindowBits -windowBitsD = \ f (Params c d) -> (\wb -> Params c (d {decompressWindowBits = wb})) <$> f (decompressWindowBits d) -{-# INLINE windowBitsD #-} - --- | --- The amount of memory allowed for the internal compression state. -memoryLevelC :: Lens' Params MemoryLevel -memoryLevelC = \ f (Params c d) -> (\ml -> Params (c {compressMemoryLevel = ml}) d) <$> f (compressMemoryLevel c) -{-# INLINE memoryLevelC #-} - --- | --- The compression strategy. -strategyC :: Lens' Params CompressionStrategy -strategyC = \ f (Params c d) -> (\s -> Params (c {compressStrategy = s}) d) <$> f (compressStrategy c) -{-# INLINE strategyC #-} - --- | --- The initial buffer size during compression. -bufferSizeC :: Lens' Params Int -bufferSizeC = \ f (Params c d) -> (\bs -> Params (c {compressBufferSize = bs}) d) <$> f (compressBufferSize c) -{-# INLINE bufferSizeC #-} - --- | --- The initial buffer size during decompression. -bufferSizeD :: Lens' Params Int -bufferSizeD = \ f (Params c d) -> (\bs -> Params c (d {decompressBufferSize = bs})) <$> f (decompressBufferSize d) -{-# INLINE bufferSizeD #-} - --- | --- 'Just' the custom (de)compression dictionary to use, or 'Nothing' to not use a custom dictionary. -dictionary :: Lens' Params (Maybe S.ByteString) -dictionary = \f (Params c d) -> (\mbs -> Params (c {compressDictionary = mbs}) (d {decompressDictionary = mbs})) <$> f (compressDictionary c <|> decompressDictionary d) -{-# INLINE dictionary #-} diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs --- a/src/Control/Exception/Lens.hs +++ b/src/Control/Exception/Lens.hs @@ -4,25 +4,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_exceptions -#define MIN_VERSION_exceptions 1 -#endif +#include "lens-common.h" -#if !(MIN_VERSION_exceptions(0,4,0)) -#define MonadThrow MonadCatch -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -35,7 +29,7 @@ -- be found in "System.IO.Error.Lens". -- -- The combinators in this module have been generalized to work with --- 'MonadCatch' instead of just 'IO'. This enables them to be used +-- 'MonadCatch' instead of just 'Prelude.IO'. This enables them to be used -- more easily in 'Monad' transformer stacks. ---------------------------------------------------------------------------- module Control.Exception.Lens @@ -47,61 +41,113 @@ , 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 -#if MIN_VERSION_base(4,6,0) + , _Overflow, _Underflow, _LossOfPrecision, _DivideByZero, _Denormal , _RatioZeroDenominator -#endif + , 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 @@ -117,36 +163,45 @@ ( const, either, flip, id , (.) , Maybe(..), Either(..), String + , Bool(..) ) -#ifdef HLINT -{-# ANN module "HLint: ignore Use Control.Exception.catch" #-} +{- +$setup +>>> :set -XNoOverloadedStrings +>>> :set -XScopedTypeVariables +>>> import Control.Lens +>>> import Control.Applicative +>>> :m + Control.Exception Control.Monad Data.List Prelude +#if MIN_VERSION_base(4,20,0) +>>> :m + Control.Exception.Context #endif - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :m + Control.Exception Control.Monad Data.List Prelude +-} ------------------------------------------------------------------------------ -- Exceptions as Prisms ------------------------------------------------------------------------------ --- | Traverse the strongly typed 'Exception' contained in 'SomeException' where the type of your function matches --- the desired 'Exception'. +-- | Traverse the strongly typed t'Exception' contained in 'SomeException' where the type of your function matches +-- the desired t'Exception'. -- -- @ --- 'exception' :: ('Applicative' f, 'Exception' a) +-- '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 'Prism' (or any 'Getter', really). +-- | Catch exceptions that match a given t'Prism' (or any t'Fold', really). -- -- >>> catching _AssertionFailed (assert False (return "uncaught")) $ \ _ -> return "caught" -- "caught" @@ -156,16 +211,16 @@ -- 'catching' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r +-- 'catching' :: '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 'Prism' (or any 'Getter'), discarding --- the information about the match. This is particuarly useful when you have --- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't +-- | 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" @@ -176,8 +231,8 @@ -- 'catching_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r --- 'catching_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r --- 'catching_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r +-- 'catching_' :: '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) @@ -198,8 +253,8 @@ -- 'handling' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r +-- 'handling' :: '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) @@ -216,8 +271,8 @@ -- 'handling_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r --- 'handling_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r --- 'handling_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r +-- 'handling_' :: '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) @@ -227,17 +282,17 @@ -- Trying ------------------------------------------------------------------------------ --- | A variant of 'Control.Exception.try' that takes a 'Prism' (or any 'Getter') to select which +-- | 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 --- 'Exception' does not match the predicate, it is re-thrown. +-- 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 => 'Getter' 'SomeException' a -> m r -> m ('Either' a r) --- 'trying' :: 'MonadCatch' m => 'Fold' '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) @@ -250,8 +305,8 @@ -- 'trying_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m (Maybe r) --- 'trying_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m (Maybe r) --- 'trying_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m (Maybe r) +-- 'trying_' :: 'MonadCatch' m => 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 @@ -261,8 +316,8 @@ -- Throwing ------------------------------------------------------------------------------ --- | Throw an 'Exception' described by a 'Prism'. Exceptions may be thrown from --- purely functional code, but may only be caught within the 'IO' 'Monad'. +-- | 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' @@ -272,14 +327,26 @@ -- 'throwing' :: 'Prism'' 'SomeException' t -> t -> r -- 'throwing' :: 'Iso'' 'SomeException' t -> t -> r -- @ -throwing :: AReview s SomeException a b -> b -> r +throwing :: AReview SomeException b -> b -> r throwing l = reviews l Exception.throw {-# INLINE throwing #-} --- | A variant of 'throwing' that can only be used within the 'IO' 'Monad' --- (or any other 'MonadCatch' instance) to throw an 'Exception' described --- by a 'Prism'. +-- | 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: -- @@ -288,10 +355,10 @@ -- 'throwingM' l e \`seq\` x ≡ x -- @ -- --- The first example will cause the 'Exception' @e@ to be raised, whereas the --- second one won't. In fact, 'throwingM' will only cause an 'Exception' to +-- 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 'Exception' +-- 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. -- @@ -303,11 +370,11 @@ -- 'throwingM' :: 'MonadThrow' m => 'Prism'' 'SomeException' t -> t -> m r -- 'throwingM' :: 'MonadThrow' m => 'Iso'' 'SomeException' t -> t -> m r -- @ -throwingM :: MonadThrow m => AReview s SomeException a b -> b -> m r +throwingM :: MonadThrow m => AReview SomeException b -> b -> m r throwingM l = reviews l throwM {-# INLINE throwingM #-} --- | 'throwingTo' raises an 'Exception' specified by a 'Prism' in the target thread. +-- | 'throwingTo' raises an t'Exception' specified by a t'Prism' in the target thread. -- -- @ -- 'throwingTo' thread l ≡ 'reviews' l ('throwTo' thread) @@ -317,7 +384,7 @@ -- 'throwingTo' :: 'ThreadId' -> 'Prism'' 'SomeException' t -> t -> m a -- 'throwingTo' :: 'ThreadId' -> 'Iso'' 'SomeException' t -> t -> m a -- @ -throwingTo :: MonadIO m => ThreadId -> AReview s SomeException a b -> b -> m () +throwingTo :: MonadIO m => ThreadId -> AReview SomeException b -> b -> m () throwingTo tid l = reviews l (liftIO . throwTo tid) {-# INLINE throwingTo #-} @@ -325,14 +392,14 @@ -- Mapping ---------------------------------------------------------------------------- --- | This 'Setter' can be used to purely map over the 'Exception's an +-- | 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 'Exception's is detailed in “A Semantics for Imprecise Exceptions” by +-- 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: @@ -344,7 +411,7 @@ {-# INLINE mappedException #-} -- | This is a type restricted version of 'mappedException', which avoids --- the type ambiguity in the input 'Exception' when using 'set'. +-- the type ambiguity in the input t'Exception' when using 'set'. -- -- The following maps any exception to arithmetic overflow: -- @@ -358,14 +425,14 @@ -- IOException ---------------------------------------------------------------------------- --- | Exceptions that occur in the 'IO' 'Monad'. An 'IOException' records a +-- | 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 'ioException' is taken by @base@ for + -- | Unfortunately the name 'GHC.IO.Exception.ioException' is taken by @base@ for -- throwing IOExceptions. -- -- @ @@ -385,16 +452,27 @@ _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 #-} @@ -419,6 +497,10 @@ seta t = Left (pure t) {-# INLINE _Overflow #-} +pattern Overflow_ :: AsArithException s => s +pattern Overflow_ <- (has _Overflow -> True) where + Overflow_ = review _Overflow () + -- | Handle arithmetic '_Underflow'. -- -- @ @@ -435,6 +517,10 @@ 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. -- -- @ @@ -451,6 +537,10 @@ 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. -- -- @ @@ -467,6 +557,10 @@ 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. -- -- @ @@ -483,10 +577,11 @@ seta t = Left (pure t) {-# INLINE _Denormal #-} -#if MIN_VERSION_base(4,6,0) --- | Added in @base@ 4.6 in response to this libraries discussion: --- --- +pattern Denormal_ :: AsArithException s => s +pattern Denormal_ <- (has _Denormal -> True) where + Denormal_ = review _Denormal () + +-- | -- -- @ -- '_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator' @@ -502,7 +597,9 @@ seta t = Left (pure t) {-# INLINE _RatioZeroDenominator #-} -#endif +pattern RatioZeroDenominator_ :: AsArithException s => s +pattern RatioZeroDenominator_ <- (has _RatioZeroDenominator -> True) where + RatioZeroDenominator_ = review _RatioZeroDenominator () ---------------------------------------------------------------------------- -- ArrayException @@ -526,6 +623,10 @@ _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. -- -- @ @@ -542,6 +643,10 @@ 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. -- -- @ @@ -558,31 +663,61 @@ 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 - -- | This 'Exception' contains provides information about what assertion failed in the 'String'. - -- - -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("" `isInfixOf` xs) ) $ assert False (return "uncaught") - -- "caught" - -- + -- | -- @ - -- '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String' - -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' + -- '__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'. + + @ + '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String' + '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' + @ + +#if MIN_VERSION_base(4,20,0) + >>> handling exception (\ (ExceptionWithContext ctxt (_ :: AssertionFailed)) -> "caught" <$ guard ("" `isInfixOf` displayExceptionContext ctxt) ) $ assert False (return "uncaught") + "caught" +#else + -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("" `isInfixOf` xs) ) $ assert False (return "uncaught") + -- "caught" +#endif + -} _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._Wrapping AssertionFailed - {-# INLINE _AssertionFailed #-} + __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 ---------------------------------------------------------------------------- @@ -605,7 +740,11 @@ _AsyncException = exception {-# INLINE _AsyncException #-} --- | The current thread's stack exceeded its limit. Since an 'Exception' has +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. -- @@ -619,12 +758,16 @@ 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 'Exception'. +-- * It is undefined which thread receives this t'Exception'. -- -- * GHC currently does not throw 'HeapOverflow' exceptions. -- @@ -638,7 +781,11 @@ seta t = Left (pure t) {-# INLINE _HeapOverflow #-} --- | This 'Exception' is raised by another thread calling +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. -- @@ -652,7 +799,11 @@ seta t = Left (pure t) {-# INLINE _ThreadKilled #-} --- | This 'Exception' is raised by default in the main thread of the program when +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). -- @@ -666,6 +817,10 @@ seta t = Left (pure t) {-# INLINE _UserInterrupt #-} +pattern UserInterrupt_ :: AsAsyncException s => s +pattern UserInterrupt_ <- (has _UserInterrupt -> True) where + UserInterrupt_ = review _UserInterrupt () + ---------------------------------------------------------------------------- -- AsyncException ---------------------------------------------------------------------------- @@ -674,22 +829,42 @@ -- 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 - -- | There is no additional information carried in a 'NonTermination' 'Exception'. + -- | + -- @ + -- '__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.trivial NonTermination - {-# INLINE _NonTermination #-} + __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 ---------------------------------------------------------------------------- @@ -697,22 +872,42 @@ -- | Thrown when the program attempts to call atomically, from the -- 'Control.Monad.STM' package, inside another call to atomically. class AsNestedAtomically t where - -- | There is no additional information carried in a 'NestedAtomically' 'Exception'. + -- | + -- @ + -- '__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.trivial NestedAtomically - {-# INLINE _NestedAtomically #-} + __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 ---------------------------------------------------------------------------- @@ -721,22 +916,42 @@ -- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't -- ever continue. class AsBlockedIndefinitelyOnMVar t where - -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'. + -- | + -- @ + -- '__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.trivial BlockedIndefinitelyOnMVar - {-# INLINE _BlockedIndefinitelyOnMVar #-} + __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 ---------------------------------------------------------------------------- @@ -745,45 +960,85 @@ -- but there are no other references to any TVars involved, so it can't ever -- continue. class AsBlockedIndefinitelyOnSTM t where - -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'. + -- | + -- @ + -- '__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.trivial BlockedIndefinitelyOnSTM - {-# INLINE _BlockedIndefinitelyOnSTM #-} + __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' 'Exception' is raised in the main thread only. +-- 'Deadlock' t'Exception' is raised in the main thread only. class AsDeadlock t where - -- | There is no information carried in a 'Deadlock' 'Exception'. + -- | + -- @ + -- '__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.trivial Deadlock - {-# INLINE _Deadlock #-} + __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 ---------------------------------------------------------------------------- @@ -791,6 +1046,13 @@ -- | 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. -- -- @ @@ -798,21 +1060,41 @@ -- '_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._Wrapping NoMethodError - {-# INLINE _NoMethodError #-} + __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. -- -- @ @@ -820,21 +1102,41 @@ -- '_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._Wrapping PatternMatchFail - {-# INLINE _PatternMatchFail #-} + __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. -- @@ -843,15 +1145,28 @@ -- '_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._Wrapping RecConError - {-# INLINE _RecConError #-} + __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 ---------------------------------------------------------------------------- @@ -860,17 +1175,42 @@ -- 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._Wrapping RecSelError - {-# INLINE _RecSelError #-} + __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 ---------------------------------------------------------------------------- @@ -879,46 +1219,234 @@ -- 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._Wrapping RecUpdError - {-# INLINE _RecUpdError #-} + __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._Wrapping ErrorCall - {-# INLINE _ErrorCall #-} + __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 'Exception' is thrown by @lens@ when the user somehow manages to rethrow +-- | 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'. -- -- @ @@ -926,19 +1454,31 @@ -- '_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.trivial HandlingException - {-# INLINE _HandlingException #-} + __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 - diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -14,20 +14,24 @@ -- -- @ -- import Control.Lens --- data Foo a = Foo { _fooArgs :: ['String'], _fooValue :: a } --- 'makeLenses' ''Foo +-- +-- data FooBar a +-- = Foo { _x :: ['Int'], _y :: a } +-- | Bar { _x :: ['Int'] } +-- 'makeLenses' ''FooBar -- @ -- -- This defines the following lenses: -- -- @ --- fooArgs :: 'Lens'' (Foo a) ['String'] --- fooValue :: 'Lens' (Foo a) (Foo b) a b +-- x :: 'Lens'' (FooBar a) ['Int'] +-- y :: t'Traversal' (FooBar a) (FooBar b) a b -- @ -- --- You can then access the value with ('^.') and set the value of the field --- with ('.~') and can use almost any other combinator that is re-exported --- here on those fields. +-- 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 @@ -40,8 +44,7 @@ -- <> ---------------------------------------------------------------------------- module Control.Lens - ( module Control.Lens.Action - , module Control.Lens.At + ( module Control.Lens.At , module Control.Lens.Cons , module Control.Lens.Each , module Control.Lens.Empty @@ -52,7 +55,6 @@ , module Control.Lens.Iso , module Control.Lens.Lens , module Control.Lens.Level - , module Control.Lens.Loupe , module Control.Lens.Plated , module Control.Lens.Prism , module Control.Lens.Reified @@ -68,7 +70,6 @@ , module Control.Lens.Zoom ) where -import Control.Lens.Action import Control.Lens.At import Control.Lens.Cons import Control.Lens.Each @@ -80,7 +81,6 @@ import Control.Lens.Iso import Control.Lens.Lens import Control.Lens.Level -import Control.Lens.Loupe import Control.Lens.Plated import Control.Lens.Prism import Control.Lens.Reified @@ -94,7 +94,3 @@ import Control.Lens.Type import Control.Lens.Wrapped import Control.Lens.Zoom - -#ifdef HLINT -{-# ANN module "HLint: ignore Use import/export shortcut" #-} -#endif diff --git a/src/Control/Lens/Action.hs b/src/Control/Lens/Action.hs deleted file mode 100644 --- a/src/Control/Lens/Action.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.Action --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Control.Lens.Action - ( - -- * Composable Actions - Action - , act - , acts - , perform - , performs - , liftAct - , (^!) - , (^!!) - , (^!?) - - -- * Indexed Actions - , IndexedAction - , iact - , iperform - , iperforms - , (^@!) - , (^@!!) - , (^@!?) - - -- * Folds with Effects - , MonadicFold - , IndexedMonadicFold - - -- * Implementation Details - , Acting - , IndexedActing - , Effective - ) where - -import Control.Comonad -import Control.Lens.Internal.Action -import Control.Lens.Internal.Fold -import Control.Lens.Internal.Indexed -import Control.Lens.Type -import Control.Monad (liftM) -import Control.Monad.Trans.Class -import Data.Profunctor -import Data.Profunctor.Rep -import Data.Profunctor.Unsafe - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> import Control.Lens - -infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!? - --- | Used to evaluate an 'Action'. -type Acting m r s a = LensLike (Effect m r) s s a a - --- | Perform an 'Action'. --- --- @ --- 'perform' ≡ 'flip' ('^!') --- @ -perform :: Monad m => Acting m a s a -> s -> m a -perform l = getEffect #. l (Effect #. return) -{-# INLINE perform #-} - --- | Perform an 'Action' and modify the result. --- --- @ --- 'performs' :: 'Monad' m => 'Acting' m e s a -> (a -> e) -> s -> m e --- @ -performs :: (Profunctor p, Monad m) => Over p (Effect m e) s t a b -> p a e -> s -> m e -performs l f = getEffect #. l (rmap (Effect #. return) f) -{-# INLINE performs #-} - --- | Perform an 'Action'. --- --- >>> ["hello","world"]^!folded.act putStrLn --- hello --- world -(^!) :: Monad m => s -> Acting m a s a -> m a -a ^! l = getEffect (l (Effect #. return) a) -{-# INLINE (^!) #-} - --- | Perform a 'MonadicFold' and collect all of the results in a list. --- --- >>> ["ab","cd","ef"]^!!folded.acts --- ["ace","acf","ade","adf","bce","bcf","bde","bdf"] -(^!!) :: Monad m => s -> Acting m [a] s a -> m [a] -a ^!! l = getEffect (l (Effect #. return . return) a) -{-# INLINE (^!!) #-} - --- | Perform a 'MonadicFold' and collect the leftmost result. --- --- /Note:/ this still causes all effects for all elements. --- --- >>> [Just 1, Just 2, Just 3]^!?folded.acts --- Just (Just 1) --- >>> [Just 1, Nothing]^!?folded.acts --- Nothing -(^!?) :: Monad m => s -> Acting m (Leftmost a) s a -> m (Maybe a) -a ^!? l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) a -{-# INLINE (^!?) #-} - --- | Construct an 'Action' from a monadic side-effect. --- --- >>> ["hello","world"]^!folded.act (\x -> [x,x ++ "!"]) --- ["helloworld","helloworld!","hello!world","hello!world!"] --- --- @ --- 'act' :: 'Monad' m => (s -> m a) -> 'Action' m s a --- 'act' sma afb a = 'effective' (sma a '>>=' 'ineffective' '.' afb) --- @ -act :: Monad m => (s -> m a) -> IndexPreservingAction m s a -act sma pafb = cotabulate $ \ws -> effective $ do - a <- sma (extract ws) - ineffective (corep pafb (a <$ ws)) -{-# INLINE act #-} - --- | A self-running 'Action', analogous to 'Control.Monad.join'. --- --- @ --- 'acts' ≡ 'act' 'id' --- @ --- --- >>> (1,"hello")^!_2.acts.to succ --- "ifmmp" -acts :: IndexPreservingAction m (m a) a -acts = act id -{-# INLINE acts #-} - --- | Apply a 'Monad' transformer to an 'Action'. -liftAct :: (MonadTrans trans, Monad m) => Acting m a s a -> IndexPreservingAction (trans m) s a -liftAct l = act (lift . perform l) -{-# INLINE liftAct #-} - ------------------------------------------------------------------------------ --- Indexed Actions ----------------------------------------------------------------------------- - --- | Used to evaluate an 'IndexedAction'. -type IndexedActing i m r s a = Over (Indexed i) (Effect m r) s s a a - --- | Perform an 'IndexedAction'. --- --- @ --- 'iperform' ≡ 'flip' ('^@!') --- @ -iperform :: Monad m => IndexedActing i m (i, a) s a -> s -> m (i, a) -iperform l = getEffect #. l (Indexed $ \i a -> Effect (return (i, a))) -{-# INLINE iperform #-} - --- | Perform an 'IndexedAction' and modify the result. -iperforms :: Monad m => IndexedActing i m e s a -> (i -> a -> e) -> s -> m e -iperforms l = performs l .# Indexed -{-# INLINE iperforms #-} - --- | Perform an 'IndexedAction'. -(^@!) :: Monad m => s -> IndexedActing i m (i, a) s a -> m (i, a) -s ^@! l = getEffect (l (Indexed $ \i a -> Effect (return (i, a))) s) -{-# INLINE (^@!) #-} - --- | Obtain a list of all of the results of an 'IndexedMonadicFold'. -(^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s a -> m [(i, a)] -s ^@!! l = getEffect (l (Indexed $ \i a -> Effect (return [(i, a)])) s) -{-# INLINE (^@!!) #-} - --- | Perform an 'IndexedMonadicFold' and collect the 'Leftmost' result. --- --- /Note:/ this still causes all effects for all elements. -(^@!?) :: Monad m => s -> IndexedActing i m (Leftmost (i, a)) s a -> m (Maybe (i, a)) -a ^@!? l = liftM getLeftmost .# getEffect $ l (Indexed $ \i -> Effect #. return . LLeaf . (,) i) a -{-# INLINE (^@!?) #-} - --- | Construct an 'IndexedAction' from a monadic side-effect. -iact :: Monad m => (s -> m (i, a)) -> IndexedAction i m s a -iact smia iafb s = effective $ do - (i, a) <- smia s - ineffective (indexed iafb i a) -{-# INLINE iact #-} diff --git a/src/Control/Lens/At.hs b/src/Control/Lens/At.hs --- a/src/Control/Lens/At.hs +++ b/src/Control/Lens/At.hs @@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} @@ -15,13 +14,12 @@ {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.At --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -31,48 +29,69 @@ module Control.Lens.At ( -- * At - At(at), sans + At(at) + , sans + , iat -- * Ixed , Index , IxValue , Ixed(ix) , ixAt + , iix -- * Contains - , Contains(..) + , Contains(contains) + , icontains ) where -import Control.Applicative +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.Type -import Control.Lens.Internal.TupleIxedTH (makeAllTupleIxed) -import Data.Aeson as Aeson +import Control.Lens.Indexed +import Control.Monad (guard) import Data.Array.IArray as Array import Data.Array.Unboxed -import Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB +import qualified Data.ByteString as StrictB +import qualified Data.ByteString.Lazy as LazyB import Data.Complex +import Data.Functor (($>)) import Data.Hashable -import Data.HashMap.Lazy as HashMap -import Data.HashSet as HashSet +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 Data.IntMap as IntMap -import Data.IntSet as IntSet -import Data.List.NonEmpty as NonEmpty -import Data.Map as Map -import Data.Set as Set -import Data.Sequence as Seq -import Data.Text as StrictT -import Data.Text.Lazy as LazyT -import Data.Traversable +import 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 Data.Vector as Vector hiding (indexed) -import Data.Vector.Primitive as Prim -import Data.Vector.Storable as Storable -import Data.Vector.Unboxed as Unboxed +import 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) +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif import Data.Word +import Foreign.Storable (Storable) -type family Index (s :: *) :: * +type family Index (s :: Type) :: Type type instance Index (e -> a) = e type instance Index IntSet = Int type instance Index (Set a) = a @@ -97,6 +116,9 @@ type instance Index (Prim.Vector a) = Int type instance Index (Storable.Vector a) = Int type instance Index (Unboxed.Vector a) = Int +#if MIN_VERSION_vector(0,13,2) +type instance Index (VectorStrict.Vector a) = Int +#endif type instance Index (Complex a) = Int type instance Index (Identity a) = () type instance Index (Maybe a) = () @@ -105,18 +127,22 @@ type instance Index LazyT.Text = Int64 type instance Index StrictB.ByteString = Int type instance Index LazyB.ByteString = Int64 -type instance Index Aeson.Value = StrictT.Text -- $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 :: 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 'IndexedFold' (or 'IndexedTraversal') that lets you view (and modify) +-- 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 -- | @@ -130,32 +156,67 @@ -- 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 - contains k f s = f (IntSet.member k s) <&> \b -> - if b then IntSet.insert k s else IntSet.delete k s +#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 = f (HashSet.member k s) <&> \b -> - if b then HashSet.insert k s else HashSet.delete k s + 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 family IxValue (m :: Type) :: Type --- | This simple 'AffineTraversal' lets you 'traverse' the value at a given +-- | 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 - -- | This simple 'AffineTraversal' lets you 'traverse' the value at a given - -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. - -- - -- /NB:/ Setting the value of this 'AffineTraversal' will only set the value in the - -- 'Lens' if it is already present. + -- | + -- /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'. -- @@ -171,12 +232,27 @@ -- >>> Seq.fromList [] ^? ix 2 -- Nothing ix :: Index m -> Traversal' m (IxValue m) -#ifdef DEFAULT_SIGNATURES - default ix :: (Applicative f, At m) => Index m -> LensLike' f m (IxValue m) + default ix :: At m => Index m -> Traversal' m (IxValue m) ix = ixAt {-# INLINE ix #-} -#endif +-- | 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) @@ -190,8 +266,8 @@ type instance IxValue (Maybe a) = a instance Ixed (Maybe a) where - ix () f (Just a) = Just <$> f a - ix () _ Nothing = pure Nothing + ix ~() f (Just a) = Just <$> f a + ix ~() _ Nothing = pure Nothing {-# INLINE ix #-} type instance IxValue [a] = a @@ -213,18 +289,16 @@ type instance IxValue (Identity a) = a instance Ixed (Identity a) where - ix () f (Identity a) = Identity <$> f a + 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 <$> goto is as i - goto is (a:as) 0 = go is a <&> (:as) - goto is (_:as) n = goto is as $! n - 1 - goto _ [] _ = pure [] + 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 @@ -258,21 +332,21 @@ type instance IxValue (Set k) = () instance Ord k => Ixed (Set k) where ix k f m = if Set.member k m - then f () <&> \() -> Set.insert k m + 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 () <&> \() -> IntSet.insert 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 () <&> \() -> HashSet.insert k m + then f () $> m else pure m {-# INLINE ix #-} @@ -328,44 +402,54 @@ | otherwise = pure v {-# INLINE ix #-} +#if MIN_VERSION_vector(0,13,2) +type instance IxValue (VectorStrict.Vector a) = a +instance Ixed (VectorStrict.Vector a) where + ix i f v + | 0 <= i && i < VectorStrict.length v = f (v VectorStrict.! i) <&> \a -> v VectorStrict.// [(i, a)] + | otherwise = pure v + {-# INLINE ix #-} +#endif + type instance IxValue StrictT.Text = Char instance Ixed StrictT.Text where - ix e f s = 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] + 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 = 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) + 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 = 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] + 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 = 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 #-} - - -type instance IxValue Aeson.Value = Aeson.Value -instance Ixed Aeson.Value where - ix i f (Object o) = Object <$> ix i f o - ix _ _ v = pure v + 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 #-} @@ -391,54 +475,130 @@ -- 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 + 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 m = f mv <&> \r -> case r of - Nothing -> maybe m (const (HashMap.delete k m)) mv - Just v' -> HashMap.insert k v' m - where mv = HashMap.lookup k m + at k f = HashMap.alterF f k {-# INLINE at #-} instance At IntSet where - at k f m = f mv <&> \r -> case r of - Nothing -> maybe m (const (IntSet.delete k m)) mv - Just () -> IntSet.insert k m - where mv = if IntSet.member k m then Just () else Nothing + -- 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 () -> Set.insert k m + 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 m = f mv <&> \r -> case r of - Nothing -> maybe m (const (HashSet.delete k m)) mv - Just () -> HashSet.insert k m - where mv = if HashSet.member k m then Just () else Nothing + at k f s = HashSet.fromMap <$> HashMap.alterF f k (HashSet.toMap s) {-# INLINE at #-} -makeAllTupleIxed + +-- | @'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 diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs --- a/src/Control/Lens/Combinators.hs +++ b/src/Control/Lens/Combinators.hs @@ -1,7 +1,8 @@ +{-# Language CPP #-} -------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Combinators --- Copyright : (C) 2013-14 Edward Kmett +-- Copyright : (C) 2013-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -18,14 +19,7 @@ ) where import Control.Lens hiding - ( -- output from scripts/operators - (^!) - , (^!!) - , (^!?) - , (^@!) - , (^@!!) - , (^@!?) - , (<|) + ( (<|) , (|>) , (^..) , (^?) @@ -97,24 +91,28 @@ , (%%@=) , (<%@=) , (<<%@=) + , (.@=) + , (.@~) , (^#) - , ( #~ ) - , ( #%~ ) - , ( #%%~ ) - , ( #= ) - , ( #%= ) + , (#~) + , (#%~) + , (#%%~) + , (#=) + , (#%=) , (<#%~) , (<#%=) - , ( #%%= ) + , (#%%=) , (<#~) , (<#=) , (...) - , ( # ) + , (#) , (%~) , (.~) , (?~) , (<.~) , (~) , (<>=) + , (<>:~) + , (<>:=) + , (<<>:~) + , (<<>:=) + , (<|~) + , (<|=) + , (<<|~) + , (<<|=) + , (|>~) + , (|>=) + , (<|>~) + , (<|>=) , (%@~) , (%@=) + , (:>) + , (:<) ) diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs --- a/src/Control/Lens/Cons.hs +++ b/src/Control/Lens/Cons.hs @@ -1,15 +1,18 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Cons --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -24,25 +27,33 @@ , 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.Lens import Control.Lens.Prism import Control.Lens.Review +import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Type import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB +import Data.Coerce import Data.Monoid import qualified Data.Sequence as Seq -import Data.Sequence hiding ((<|), (|>)) +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) @@ -53,13 +64,20 @@ import qualified Data.Vector.Primitive as Prim import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif import Data.Word - -{-# ANN module "HLint: ignore Eta reduce" #-} +import Control.Applicative (ZipList(..)) +import Control.Monad.State.Class as State +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 @@ -67,7 +85,20 @@ infixr 5 <|, `cons` infixl 5 |>, `snoc` +infixr 4 <|~, |>~, <<|~, <|>~, <<<|~, <<|>~ +infix 4 <|=, |>=, <<|=, <|>=, <<<|=, <<|>= +pattern (:<) :: Cons b b a a => a -> b -> b +pattern (:<) a s <- (preview _Cons -> Just (a,s)) where + (:<) 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 ------------------------------------------------------------------------------ @@ -93,9 +124,18 @@ [] -> 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 :< as -> Right (a, as) + a Seq.:< as -> Right (a, as) EmptyL -> Left mempty {-# INLINE _Cons #-} @@ -143,6 +183,15 @@ else Right (Unbox.unsafeHead v, Unbox.unsafeTail v) {-# INLINE _Cons #-} +#if MIN_VERSION_vector(0,13,2) +instance Cons (VectorStrict.Vector a) (VectorStrict.Vector b) a b where + _Cons = prism (uncurry VectorStrict.cons) $ \v -> + if VectorStrict.null v + then Left VectorStrict.empty + else Right (VectorStrict.unsafeHead v, VectorStrict.unsafeTail v) + {-# INLINE _Cons #-} +#endif + -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'. @@ -293,6 +342,49 @@ _tail = _Cons._2 {-# INLINE _tail #-} +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('<|')@. +-- +-- >>> (["world"], ["lens"]) & _1 <|~ "hello" +-- (["hello","world"],["lens"]) +(<|~) :: Cons b b a a => ASetter s t b b -> a -> s -> t +l <|~ n = over l (n <|) +{-# INLINE (<|~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('<|')@. +(<|=) :: (MonadState s m, Cons b b a a) => ASetter s s b b -> a -> m () +l <|= a = State.modify (l <|~ a) +{-# INLINE (<|=) #-} + +-- | ('<|') a value onto the target of a 'Lens' and return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible. +(<<|~) :: Cons b b a a => LensLike ((,) b) s t b b -> a -> s -> (b, t) +l <<|~ m = l <%~ (m <|) +{-# INLINE (<<|~) #-} + +-- | ('<|') a value onto the target of a 'Lens' and return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible. +(<<<|~) :: Cons b b a a => LensLike' ((,) b) s b -> a -> s -> (b, s) +l <<<|~ m = l <<%~ (m <|) +{-# INLINE (<<<|~) #-} + +-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible. +(<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b +l <<|= r = l <%= (r <|) +{-# INLINE (<<|=) #-} + +-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible. +(<<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b +l <<<|= r = l <<%= (r <|) +{-# INLINE (<<<|=) #-} + ------------------------------------------------------------------------------ -- Snoc ------------------------------------------------------------------------------ @@ -318,9 +410,18 @@ 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 :> a -> Right (as, a) + as Seq.:> a -> Right (as, a) EmptyR -> Left mempty {-# INLINE _Snoc #-} @@ -441,8 +542,8 @@ -- >>> Vector.empty ^? _last -- Nothing -- --- >>> Vector.fromList "abcde" & _last .~ 'Q' --- fromList "abcdQ" +-- >>> (Vector.fromList "abcde" & _last .~ 'Q') == Vector.fromList "abcdQ" +-- True -- -- @ -- '_last' :: 'Traversal'' [a] a @@ -453,7 +554,7 @@ _last = _Snoc._2 {-# INLINE _last #-} --- | 'snoc' an element onto the end of a container. +-- | 'snoc' an element onto a container. -- -- This is an infix alias for 'snoc'. -- @@ -469,7 +570,7 @@ (|>) = curry (simply review _Snoc) {-# INLINE (|>) #-} --- | 'snoc' an element onto the end of a container. +-- | 'snoc' an element onto a container. -- -- >>> snoc (Seq.fromList []) a -- fromList [a] @@ -497,5 +598,48 @@ -- >>> unsnoc (Seq.fromList []) -- Nothing unsnoc :: Snoc s s a a => s -> Maybe (s, a) -unsnoc s = simply preview _Snoc s +unsnoc = simply preview _Snoc {-# INLINE unsnoc #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('|>')@. +-- +-- >>> (["world"], ["lens"]) & _1 |>~ "hello" +-- (["world","hello"],["lens"]) +(|>~) :: Snoc b b a a => ASetter s t b b -> a -> s -> t +l |>~ n = over l (|> n) +{-# INLINE (|>~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('|>')@. +(|>=) :: (MonadState s m, Snoc b b a a) => ASetter s s b b -> a -> m () +l |>= a = State.modify (l |>~ a) +{-# INLINE (|>=) #-} + +-- | ('|>') a value onto the target of a 'Lens' and return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible. +(<|>~) :: Snoc b b p p => LensLike ((,) b) s t b b -> p -> s -> (b, t) +l <|>~ m = l <%~ (|> m) +{-# INLINE (<|>~) #-} + +-- | ('|>') a value onto the target of a 'Lens' and return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible. +(<<|>~) :: Snoc b b p p => LensLike' ((,) b) s b -> p -> s -> (b, s) +l <<|>~ m = l <<%~ (|> m) +{-# INLINE (<<|>~) #-} + +-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible. +(<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b +l <|>= r = l <%= (|> r) +{-# INLINE (<|>=) #-} + +-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible. +(<<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b +l <<|>= r = l <<%= (|> r) +{-# INLINE (<<|>=) #-} diff --git a/src/Control/Lens/Each.hs b/src/Control/Lens/Each.hs --- a/src/Control/Lens/Each.hs +++ b/src/Control/Lens/Each.hs @@ -1,20 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} #endif + +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Each --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -27,32 +29,38 @@ Each(..) ) where -import Control.Applicative -import Control.Lens.Iso -import Control.Lens.Type +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 Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB +import qualified Data.ByteString as StrictB +import qualified Data.ByteString.Lazy as LazyB import Data.Complex -import Data.Functor.Identity -import Data.HashMap.Lazy as HashMap -import Data.IntMap as IntMap -import Data.List.NonEmpty -import Data.Map as Map -import Data.Sequence as Seq -import Data.Text as StrictT -import Data.Text.Lazy as LazyT +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 +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif import Data.Vector.Unboxed (Unbox) import Data.Word +import qualified Data.Strict as S +import Data.These (These (..)) -- $setup -- >>> :set -XNoOverloadedStrings @@ -76,11 +84,9 @@ -- ("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 -#ifndef HLINT - default each :: (Applicative f, Traversable g, s ~ g a, t ~ g b) => LensLike f s t a b + default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b each = traverse {-# INLINE each #-} -#endif -- | @'each' :: 'Traversal' (a,a) (b,b) a b@ instance (a~a', b~b') => Each (a,a') (b,b') a b where @@ -122,29 +128,30 @@ each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i <*> f j {-# INLINE each #-} -#if MIN_VERSION_base(4,4,0) -- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'Traversal' ('Complex' a) ('Complex' b) a b@ instance Each (Complex a) (Complex b) a b where each f (a :+ b) = (:+) <$> f a <*> f b {-# INLINE each #-} -#else --- | @'each' :: 'Traversal' ('Complex' a) ('Complex' b) a b@ -instance (RealFloat a, RealFloat b) => Each (Complex a) (Complex b) a b where - each f (a :+ b) = (:+) <$> f a <*> f b - {-# INLINE each #-} -#endif -- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@ -instance (c ~ d) => Each (Map c a) (Map d 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 +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 +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 +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 @@ -155,48 +162,67 @@ -- | @'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 +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 +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 f v = Prim.fromListN (Prim.length v) <$> traverse f (Prim.toList v) + 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 f v = Storable.fromListN (Storable.length v) <$> traverse f (Storable.toList v) + 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 f v = Unboxed.fromListN (Unboxed.length v) <$> traverse f (Unboxed.toList v) + each = vectorTraverse {-# INLINE each #-} +#if MIN_VERSION_vector(0,13,2) +-- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@ +instance Each (VectorStrict.Vector a) (VectorStrict.Vector b) a b where + each = vectorTraverse + {-# INLINE each #-} +#endif + -- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@ instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where - each = iso StrictT.unpack StrictT.pack . traversed + 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 = iso LazyT.unpack LazyT.pack . traverse + 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 = iso StrictB.unpack StrictB.pack . traverse + 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 = iso LazyB.unpack LazyB.pack . traverse + each = traversedLazy {-# INLINE each #-} -- | @'each' :: 'Ix' i => 'Traversal' ('Array' i a) ('Array' i b) a b@ @@ -208,3 +234,37 @@ 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 diff --git a/src/Control/Lens/Empty.hs b/src/Control/Lens/Empty.hs --- a/src/Control/Lens/Empty.hs +++ b/src/Control/Lens/Empty.hs @@ -1,11 +1,16 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} +#endif + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Empty --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -15,45 +20,66 @@ 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 Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB -import Data.HashMap.Lazy as HashMap -import Data.HashSet as HashSet -import Data.IntMap as IntMap -import Data.IntSet as IntSet -import Data.Map as Map -import Data.Maybe +import 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 Data.Profunctor.Unsafe -import Data.Sequence as Seq -import Data.Set as Set -import Data.Text as StrictT -import Data.Text.Lazy as LazyT -import Data.Vector as Vector -import Data.Vector.Unboxed as Unboxed -import Data.Vector.Storable as Storable +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 qualified Data.Vector.Primitive as Prim +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif +import Foreign.Storable (Storable) #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) import GHC.Event #endif +-- $setup +-- >>> import Control.Lens + class AsEmpty a where -- | -- -- >>> isn't _Empty [1,2,3] -- True _Empty :: Prism' a () -#ifndef HLINT default _Empty :: (Monoid a, Eq a) => Prism' a () _Empty = only mempty {-# INLINE _Empty #-} -#endif +pattern Empty :: AsEmpty s => s +pattern Empty <- (has _Empty -> True) where + Empty = review _Empty () + {- Default Monoid instances -} instance AsEmpty Ordering instance AsEmpty () @@ -103,6 +129,10 @@ _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 #-} @@ -135,11 +165,21 @@ _Empty = nearly Unboxed.empty Unboxed.null {-# INLINE _Empty #-} +instance Prim.Prim a => AsEmpty (Prim.Vector a) where + _Empty = nearly Prim.empty Prim.null + {-# INLINE _Empty #-} + instance Storable a => AsEmpty (Storable.Vector a) where _Empty = nearly Storable.empty Storable.null {-# INLINE _Empty #-} -instance AsEmpty (Seq a) where +#if MIN_VERSION_vector(0,13,2) +instance AsEmpty (VectorStrict.Vector a) where + _Empty = nearly VectorStrict.empty VectorStrict.null + {-# INLINE _Empty #-} +#endif + +instance AsEmpty (Seq.Seq a) where _Empty = nearly Seq.empty Seq.null {-# INLINE _Empty #-} diff --git a/src/Control/Lens/Equality.hs b/src/Control/Lens/Equality.hs --- a/src/Control/Lens/Equality.hs +++ b/src/Control/Lens/Equality.hs @@ -2,10 +2,19 @@ {-# 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-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -17,6 +26,7 @@ -- * Type Equality Equality, Equality' , AnEquality, AnEquality' + , (:~:)(..) , runEq , substEq , mapEq @@ -24,21 +34,30 @@ , 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.Functor.Identity - -#ifdef HLINT -{-# ANN module "HLint: ignore Use id" #-} -{-# ANN module "HLint: ignore Eta reduce" #-} -#endif +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 ----------------------------------------------------------------------------- @@ -48,7 +67,7 @@ Identical :: Identical a b a b -- | When you see this as an argument to a function, it expects an 'Equality'. -type AnEquality s t a b = Identical a (Identity b) a (Identity b) -> Identical a (Identity b) s (Identity t) +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 @@ -59,13 +78,14 @@ {-# INLINE runEq #-} -- | Substituting types with 'Equality'. -substEq :: AnEquality s t a b -> ((s ~ a, t ~ b) => r) -> r +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 :: AnEquality s t a b -> f s -> f a +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 #-} @@ -76,7 +96,8 @@ -- | 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 :: (Optic' p f s a -> r) -> Optic' p f s a -> r +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 #-} @@ -87,3 +108,53 @@ 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 #-} diff --git a/src/Control/Lens/Extras.hs b/src/Control/Lens/Extras.hs --- a/src/Control/Lens/Extras.hs +++ b/src/Control/Lens/Extras.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -22,7 +22,7 @@ -- >>> import Control.Lens -- >>> import Numeric.Lens (hex) --- | Check to see if this 'Prism' matches. +-- | Check to see if this t'Prism' matches. -- -- >>> is _Left (Right 12) -- False diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -3,15 +3,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef TRUSTWORTHY +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Trustworthy #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} +#include "lens-common.h" +{-# OPTIONS_GHC -Wno-orphans #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -55,11 +55,13 @@ -- ** Building Folds , folding, ifolding + , foldring, ifoldring , folded , folded64 , unfolded , iterated , filtered + , filteredBy , backwards , repeated , replicated @@ -71,19 +73,21 @@ -- ** Folding , foldMapOf, foldOf , foldrOf, foldlOf - , toListOf + , 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, lastOf - , maximumOf, minimumOf + , firstOf, first1Of, lastOf, last1Of + , maximumOf, maximum1Of, minimumOf, minimum1Of , maximumByOf, minimumByOf , findOf , findMOf @@ -91,6 +95,7 @@ , foldr1Of, foldl1Of , foldr1Of', foldl1Of' , foldrMOf, foldlMOf + , lookupOf -- * Indexed Folds , (^@..) @@ -116,15 +121,16 @@ , ifoldrMOf , ifoldlMOf , itoListOf + , elemIndexOf + , elemIndicesOf + , findIndexOf + , findIndicesOf -- ** Building Indexed Folds , ifiltered , itakingWhile , idroppingWhile - -- * Deprecated - , headOf - -- * Internal types , Leftmost , Rightmost @@ -138,7 +144,8 @@ , foldMapByOf ) where -import Control.Applicative as Applicative +import Prelude () + import Control.Applicative.Backwards import Control.Comonad import Control.Lens.Getter @@ -146,44 +153,40 @@ 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.Foldable as Foldable -import Data.Functor.Apply -import Data.Functor.Compose +import Data.CallStack +import Data.Functor.Apply hiding ((<.)) import Data.Int (Int64) import Data.List (intercalate) -import Data.Maybe -import Data.Monoid -import Data.Profunctor -import Data.Profunctor.Rep -import Data.Profunctor.Unsafe -import Data.Traversable +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 -#ifdef HLINT -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Use camelCase" #-} -{-# ANN module "HLint: ignore Use curry" #-} -#endif - infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! -------------------------- @@ -194,16 +197,29 @@ -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -- --- >>> [1,2,3,4]^..folding tail --- [2,3,4] -folding :: (Foldable f, Contravariant g, Applicative g) => (s -> f a) -> LensLike g s t a b -folding sfa agb = coerce . traverse_ agb . sfa +-- >>> [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 = coerce . traverse_ (coerce . uncurry (indexed f)) . sfa +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 @@ -215,17 +231,21 @@ -- >>> [(1,2),(3,4)]^..folded.both -- [1,2,3,4] folded :: Foldable f => IndexedFold Int (f a) a -folded = conjoined folded' (indexing folded') +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 folded' (indexing64 folded') +folded64 = conjoined (foldring foldr) (ifoldring ifoldr64) {-# INLINE folded64 #-} -folded' :: Foldable f => Fold (f a) a -folded' f = coerce . getFolding . foldMap (Folding #. f) -{-# INLINE folded' #-} +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. -- @@ -235,7 +255,11 @@ -- -- >>> 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' :: 'Fold1' a a +-- @ +repeated :: Apply f => LensLike' f a a repeated f a = as where as = f a .> as {-# INLINE repeated #-} @@ -258,7 +282,11 @@ -- -- >>> timingOut $ [1,2,3]^..taking 7 (cycled traverse) -- [1,2,3,1,2,3,1] -cycled :: (Contravariant f, Apply f) => LensLike f s t a b -> LensLike f s t a b +-- +-- @ +-- '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 #-} @@ -271,7 +299,7 @@ -- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1)) -- [10,9,8,7,6,5,4,3,2,1] unfolded :: (b -> Maybe (a, b)) -> Fold b a -unfolded f g b0 = go b0 where +unfolded f g = go where go b = case f b of Just (a, b') -> g a *> go b' Nothing -> noEffect @@ -282,16 +310,20 @@ -- @ -- 'toListOf' ('iterated' f) a ≡ 'iterate' f a -- @ -iterated :: (a -> a) -> Fold1 a a -iterated f g a0 = go a0 where +-- +-- @ +-- '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 an 'AffineFold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). +-- | Obtain a 'Fold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). -- --- Note: This is /not/ a legal 'AffineTraversal', unless you are very careful not to invalidate the predicate on the target. +-- Note: This is /not/ a legal 'Traversal', unless you are very careful not to invalidate the predicate on the target. -- --- Note: This is also /not/ a legal 'Prism', unless you are very careful not to inject a value that matches the predicate. +-- 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: -- @@ -299,7 +331,7 @@ -- '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 'AffineTraversal' you can only use it for actions that preserve the result of the predicate! +-- 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] @@ -309,6 +341,24 @@ 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. -- -- @ @@ -335,7 +385,7 @@ -- which is not a 'Traversal' per the laws, unless you are careful to ensure that you do not invalidate the predicate when -- writing back through it. takingWhile :: (Conjoined p, Applicative f) => (a -> Bool) -> Over p (TakingWhile p f a a) s t a a -> Over p f s t a a -takingWhile p l pafb = fmap runMagma . traverse (corep pafb) . runTakingWhile . l flag where +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 #-} @@ -377,8 +427,29 @@ -- -- Note: Many uses of this combinator will yield something that meets the types, but not the laws of a valid -- 'Traversal' or 'IndexedTraversal'. The 'Traversal' and 'IndexedTraversal' laws are only satisfied if the --- new values you assign also pass the predicate! Otherwise subsequent traversals will visit fewer elements --- and 'Traversal' fusion is not sound. +-- 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 @@ -387,7 +458,7 @@ g = cotabulate $ \wa -> Compose $ state $ \b -> let a = extract wa b' = b && p a - in (if b' then pure a else corep f wa, b') + in (if b' then pure a else cosieve f wa, b') {-# INLINE droppingWhile #-} -- | A 'Fold' over the individual 'words' of a 'String'. @@ -432,7 +503,13 @@ -- 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' -- @ -- @@ -442,22 +519,30 @@ -- @ -- -- @ --- 'foldMapOf' :: 'Getter' s a -> (a -> r) -> s -> r --- 'foldMapOf' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r --- 'foldMapOf' :: 'Lens'' s a -> (a -> r) -> s -> r --- 'foldMapOf' :: 'Iso'' s a -> (a -> r) -> s -> r --- 'foldMapOf' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r --- 'foldMapOf' :: 'Monoid' r => 'Prism'' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: '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 :: Profunctor p => Accessing p r s a -> p a r -> s -> r -foldMapOf l f = getConst #. l (Const #. f) +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' -- @ -- @@ -499,8 +584,8 @@ -- @ -- 'foldrOf' :: 'Getting' ('Endo' r) s a -> (a -> r -> r) -> r -> s -> r -- @ -foldrOf :: Profunctor p => Accessing p (Endo r) s a -> p a (r -> r) -> r -> s -> r -foldrOf l f z = flip appEndo z `rmap` foldMapOf l (Endo #. f) +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'. @@ -543,8 +628,54 @@ 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] -- @@ -627,7 +758,7 @@ -- @ -- -- @ --- 'ianyOf' l ≡ 'allOf' l '.' 'Indexed' +-- 'ianyOf' l ≡ 'anyOf' l '.' 'Indexed' -- @ -- -- @ @@ -638,7 +769,7 @@ -- 'anyOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -anyOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool +anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool anyOf l f = getAny #. foldMapOf l (Any #. f) {-# INLINE anyOf #-} @@ -665,7 +796,7 @@ -- 'allOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -allOf :: Profunctor p => Accessing p All s a -> p a Bool -> s -> Bool +allOf :: Getting All s a -> (a -> Bool) -> s -> Bool allOf l f = getAll #. foldMapOf l (All #. f) {-# INLINE allOf #-} @@ -688,7 +819,7 @@ -- 'noneOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -noneOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool +noneOf :: Getting Any s a -> (a -> Bool) -> s -> Bool noneOf l f = not . anyOf l f {-# INLINE noneOf #-} @@ -702,9 +833,9 @@ -- @ -- 'Data.Foldable.product' ≡ 'productOf' 'folded' -- @ - +-- -- This operation may be more strict than you would expect. If you --- want a lazier version use @'ala' 'Sum' '.' 'foldMapOf'@ +-- want a lazier version use @'ala' 'Product' '.' 'foldMapOf'@ -- -- @ -- 'productOf' :: 'Num' a => 'Getter' s a -> s -> a @@ -788,7 +919,7 @@ -- 'traverseOf_' :: 'Applicative' f => 'Traversal'' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Prism'' s a -> (a -> f r) -> s -> f () -- @ -traverseOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> p a (f r) -> s -> f () +traverseOf_ :: Functor f => Getting (Traversed r f) s a -> (a -> f r) -> s -> f () traverseOf_ l f = void . getTraversed #. foldMapOf l (Traversed #. f) {-# INLINE traverseOf_ #-} @@ -821,7 +952,7 @@ -- 'forOf_' :: 'Applicative' f => 'Traversal'' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Prism'' s a -> s -> (a -> f r) -> f () -- @ -forOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> s -> p a (f r) -> f () +forOf_ :: Functor f => Getting (Traversed r f) s a -> s -> (a -> f r) -> f () forOf_ = flip . traverseOf_ {-# INLINE forOf_ #-} @@ -847,6 +978,48 @@ 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") @@ -865,7 +1038,7 @@ -- 'mapMOf_' :: 'Monad' m => 'Traversal'' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Prism'' s a -> (a -> m r) -> s -> m () -- @ -mapMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> p a (m r) -> s -> m () +mapMOf_ :: 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_ #-} @@ -887,7 +1060,7 @@ -- 'forMOf_' :: 'Monad' m => 'Traversal'' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Prism'' s a -> s -> (a -> m r) -> m () -- @ -forMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> s -> p a (m r) -> m () +forMOf_ :: Monad m => Getting (Sequenced r m) s a -> s -> (a -> m r) -> m () forMOf_ = flip . mapMOf_ {-# INLINE forMOf_ #-} @@ -934,7 +1107,7 @@ -- 'asumOf' :: 'Alternative' f => 'Prism'' s (f a) -> s -> f a -- @ asumOf :: Alternative f => Getting (Endo (f a)) s (f a) -> s -> f a -asumOf l = foldrOf l (<|>) Applicative.empty +asumOf l = foldrOf l (<|>) empty {-# INLINE asumOf #-} -- | The sum of a collection of actions, generalizing 'concatOf'. @@ -1022,8 +1195,8 @@ -- 'concatMapOf' :: 'Iso'' s a -> (a -> [r]) -> s -> [r] -- 'concatMapOf' :: 'Traversal'' s a -> (a -> [r]) -> s -> [r] -- @ -concatMapOf :: Profunctor p => Accessing p [r] s a -> p a [r] -> s -> [r] -concatMapOf l ces = getConst #. l (Const #. ces) +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. @@ -1088,7 +1261,8 @@ -- 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. +-- 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 @@ -1102,10 +1276,15 @@ -- >>> "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 @@ -1132,17 +1311,21 @@ -- ('^?!') :: s -> 'Iso'' s a -> a -- ('^?!') :: s -> 'Traversal'' s a -> a -- @ -(^?!) :: s -> Getting (Endo a) 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 @'ala' 'First' '.' 'foldMapOf'@ --- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse --- constant factors. +-- 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 -- @@ -1163,6 +1346,32 @@ 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'. -- @@ -1190,6 +1399,25 @@ 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'. @@ -1234,7 +1462,7 @@ -- Note: 'notNullOf' on a valid 'Iso', 'Lens' or 'Getter' should always return 'True'. -- -- @ --- 'null' ≡ 'notNullOf' 'folded' +-- 'not' '.' 'null' ≡ 'notNullOf' 'folded' -- @ -- -- This may be rather inefficient compared to the @'not' '.' 'null'@ check of many containers. @@ -1299,6 +1527,22 @@ 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. @@ -1333,6 +1577,22 @@ 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'. -- @@ -1412,8 +1672,8 @@ -- 'findOf' :: 'Getting' ('Endo' ('Maybe' a)) s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' l p = 'foldrOf' l (\a y -> if p a then 'Just' a else y) 'Nothing' -- @ -findOf :: Conjoined p => Accessing p (Endo (Maybe a)) s a -> p a Bool -> s -> Maybe a -findOf l p = foldrOf l (cotabulate $ \wa y -> if corep p wa then Just (extract wa) else y) Nothing +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'), @@ -1452,10 +1712,28 @@ -- 'findMOf' :: Monad m => 'Getting' ('Endo' (m ('Maybe' a))) s a -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' l p = 'foldrOf' l (\a y -> p a >>= \x -> if x then return ('Just' a) else y) $ return 'Nothing' -- @ -findMOf :: (Monad m, Conjoined p) => Accessing p (Endo (m (Maybe a))) s a -> p a (m Bool) -> s -> m (Maybe a) -findMOf l p = foldrOf l (cotabulate $ \wa y -> corep p wa >>= \r -> if r then return (Just (extract wa)) else y) $ return Nothing +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. @@ -1475,9 +1753,10 @@ -- 'foldr1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldr1Of :: Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a -foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") - (foldrOf l mf Nothing xs) where +foldr1Of :: HasCallStack => Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a +-- See: NOTE: [Inlining and arity] +foldr1Of l f = fromMaybe (error "foldr1Of: empty structure") + . foldrOf l mf Nothing where mf x my = Just $ case my of Nothing -> x Just y -> f x y @@ -1501,8 +1780,9 @@ -- 'foldl1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldl1Of :: Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a -foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where +foldl1Of :: HasCallStack => Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a +-- See: NOTE: [Inlining and arity] +foldl1Of l f = fromMaybe (error "foldl1Of: empty structure") . foldlOf l mf Nothing where mf mx y = Just $ case mx of Nothing -> y Just x -> f x y @@ -1522,7 +1802,8 @@ -- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r -foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0 +-- See: NOTE: [Inlining and arity] +foldrOf' l f z0 = \xs -> foldlOf l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldrOf' #-} @@ -1540,7 +1821,8 @@ -- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r -foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0 +-- See: NOTE: [Inlining and arity] +foldlOf' l f z0 = \xs -> foldrOf l f' (Endo id) xs `appEndo` z0 where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} @@ -1559,8 +1841,9 @@ -- 'foldr1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldr1Of' :: Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a -foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where +foldr1Of' :: HasCallStack => Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a +-- See: NOTE: [Inlining and arity] +foldr1Of' l f = fromMaybe (error "foldr1Of': empty structure") . foldrOf' l mf Nothing where mf x Nothing = Just $! x mf x (Just y) = Just $! f x y {-# INLINE foldr1Of' #-} @@ -1580,8 +1863,9 @@ -- 'foldl1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldl1Of' :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a -foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where +foldl1Of' :: HasCallStack => Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a +-- See: NOTE: [Inlining and arity] +foldl1Of' l f = fromMaybe (error "foldl1Of': empty structure") . foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! f x y {-# INLINE foldl1Of' #-} @@ -1603,7 +1887,8 @@ foldrMOf :: Monad m => Getting (Dual (Endo (r -> m r))) s a -> (a -> r -> m r) -> r -> s -> m r -foldrMOf l f z0 xs = foldlOf l f' return xs z0 +-- See: NOTE: [Inlining and arity] +foldrMOf l f z0 = \xs -> foldlOf l f' return xs z0 where f' k x z = f x z >>= k {-# INLINE foldrMOf #-} @@ -1624,10 +1909,26 @@ foldlMOf :: Monad m => Getting (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r -foldlMOf l f z0 xs = foldrOf l f' return xs z0 +-- See: NOTE: [Inlining and arity] +foldlMOf l f z0 = \xs -> foldrOf l f' return xs z0 where f' x k z = f z x >>= k {-# INLINE foldlMOf #-} +-- NOTE: [Inlining and arity] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- GHC uses the following inlining heuristic: a function body is inlined if +-- all its arguments on the LHS are applied. So the following two definitions +-- are not equivalent from the inliner's PoV: +-- +-- > foldlOf' l f z0 xs = ... +-- > foldlOf' l f z0 = \xs -> ... +-- +-- GHC will be less eager to inline the first one and this results in +-- worse code. For example, a simple list summation using `sumOf` will be 8x slower +-- with the first version. + + -- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries. -- -- >>> has (element 0) [] @@ -1676,28 +1977,28 @@ -- exists, as a 'Maybe'. -- -- @ --- 'pre' :: 'Getter' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Fold' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Simple' 'Traversal' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Simple' 'Lens' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Simple' 'Iso' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Simple' 'Prism' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: '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)) coerce +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' :: 'Simple' ('IndexedTraversal' i) s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) --- 'ipre' :: 'Simple' ('IndexedLens' i) s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- '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))))) coerce +ipre l = dimap (getFirst . getConst #. l (Indexed $ \i a -> Const (First (Just (i, a))))) phantom {-# INLINE ipre #-} ------------------------------------------------------------------------------ @@ -1705,19 +2006,33 @@ ------------------------------------------------------------------------------ -- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result --- from a 'Getter' or 'Lens'). See also ('^?'). +-- from a 'Getter' or 'Lens'). See also 'firstOf' and '^?', which are similar with +-- some subtle differences (explained below). -- -- @ -- 'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded' -- @ -- --- This is usually applied in the 'Control.Monad.Reader.Reader' --- 'Control.Monad.Monad' @(->) s@. --- -- @ -- '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 @@ -1726,8 +2041,6 @@ -- 'preview' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ -- --- However, it may be useful to think of its full generality when working with --- a 'Control.Monad.Monad' transformer stack: -- -- @ -- 'preview' :: 'MonadReader' s m => 'Getter' s a -> m ('Maybe' a) @@ -1735,6 +2048,7 @@ -- '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)) @@ -1946,7 +2260,7 @@ -- @ -- ifoldMapOf :: IndexedGetting i m s a -> (i -> a -> m) -> s -> m -ifoldMapOf l = foldMapOf l .# Indexed +ifoldMapOf = coerce {-# INLINE ifoldMapOf #-} -- | Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with @@ -1965,7 +2279,7 @@ -- 'ifoldrOf' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- @ ifoldrOf :: IndexedGetting i (Endo r) s a -> (i -> a -> r -> r) -> r -> s -> r -ifoldrOf l = foldrOf l .# Indexed +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 @@ -2003,7 +2317,7 @@ -- 'ianyOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ ianyOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool -ianyOf l = anyOf l .# Indexed +ianyOf = coerce {-# INLINE ianyOf #-} -- | Return whether or not all elements viewed through an 'IndexedFold' or 'IndexedTraversal' @@ -2022,7 +2336,7 @@ -- 'iallOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ iallOf :: IndexedGetting i All s a -> (i -> a -> Bool) -> s -> Bool -iallOf l = allOf l .# Indexed +iallOf = coerce {-# INLINE iallOf #-} -- | Return whether or not none of the elements viewed through an 'IndexedFold' or 'IndexedTraversal' @@ -2041,7 +2355,7 @@ -- 'inoneOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ inoneOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool -inoneOf l = noneOf l .# Indexed +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. @@ -2059,7 +2373,7 @@ -- 'itraverseOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> (i -> a -> f r) -> s -> f () -- @ itraverseOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> (i -> a -> f r) -> s -> f () -itraverseOf_ l = traverseOf_ l .# Indexed +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 @@ -2101,7 +2415,7 @@ -- 'imapMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m r) -> s -> m () -- @ imapMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> (i -> a -> m r) -> s -> m () -imapMOf_ l = mapMOf_ l .# Indexed +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, @@ -2164,7 +2478,7 @@ -- 'ifindOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- @ ifindOf :: IndexedGetting i (Endo (Maybe a)) s a -> (i -> a -> Bool) -> s -> Maybe a -ifindOf l = findOf l .# Indexed +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 @@ -2184,7 +2498,7 @@ -- 'ifindMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) -- @ ifindMOf :: Monad m => IndexedGetting i (Endo (m (Maybe a))) s a -> (i -> a -> m Bool) -> s -> m (Maybe a) -ifindMOf l = findMOf l .# Indexed +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. @@ -2268,7 +2582,7 @@ -- When you don't need access to the indices in the result, then 'toListOf' is more flexible in what it accepts. -- -- @ --- 'toListOf' l ≡ 'map' 'fst' '.' 'itoListOf' l +-- 'toListOf' l ≡ 'map' 'snd' '.' 'itoListOf' l -- @ -- -- @ @@ -2317,10 +2631,66 @@ -- ('^@?!') :: s -> 'IndexedLens'' i s a -> (i, a) -- ('^@?!') :: s -> 'IndexedTraversal'' i s a -> (i, a) -- @ -(^@?!) :: s -> IndexedGetting i (Endo (i, a)) 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 ------------------------------------------------------------------------------- @@ -2330,7 +2700,7 @@ -- >>> [0,0,0,5,5,5]^..traversed.ifiltered (\i a -> i <= a) -- [0,5,5,5] -- --- Compose with 'filtered' to filter another 'IndexedLens', 'IndexedIso', 'IndexedGetter', 'IndexedFold' (or 'IndexedTraversal') with +-- 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! @@ -2347,10 +2717,14 @@ -- '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 s a a - -> Optical p q f s s a a + -> 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 #-} @@ -2364,9 +2738,10 @@ -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- @ -- --- Applying 'idroppingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still allow you to use it as a --- pseudo-'IndexedTraversal', but if you change the value of the targets to ones where the predicate returns --- 'True', then you will break the 'Traversal' laws and 'Traversal' fusion will no longer be sound. +-- 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 @@ -2378,16 +2753,6 @@ {-# INLINE idroppingWhile #-} ------------------------------------------------------------------------------ --- Deprecated ------------------------------------------------------------------------------- - --- | A deprecated alias for 'firstOf'. -headOf :: Getting (First a) s a -> s -> Maybe a -headOf l = getFirst #. foldMapOf l (First #. Just) -{-# INLINE headOf #-} -{-# DEPRECATED headOf "`headOf' will be removed after GHC 7.8 is released. (Use `preview' or `firstOf')" #-} - ------------------------------------------------------------------------------- -- Misc. ------------------------------------------------------------------------------ @@ -2399,14 +2764,44 @@ -- Folds with Reified Monoid ------------------------------------------------------------------------------ -foldBy :: Foldable t => (a -> a -> a) -> a -> t a -> a -foldBy f z = reifyFold f z (foldMap M) - -foldByOf :: (forall i. Getting (M a i) s a) -> (a -> a -> a) -> a -> s -> a -foldByOf l f z = reifyFold f z (foldMapOf l M) - -foldMapBy :: Foldable t => (r -> r -> r) -> r -> (a -> r) -> t a -> r -foldMapBy f z g = reifyFold f z (foldMap (M #. g)) +-- | 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) -foldMapByOf :: (forall s. Getting (M r s) t a) -> (r -> r -> r) -> r -> (a -> r) -> t -> r -foldMapByOf l f z g = reifyFold f z (foldMapOf l (M #. g)) +-- | 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)) diff --git a/src/Control/Lens/Getter.hs b/src/Control/Lens/Getter.hs --- a/src/Control/Lens/Getter.hs +++ b/src/Control/Lens/Getter.hs @@ -2,17 +2,17 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE NoPolyKinds #-} -{-# LANGUAGE NoDataKinds #-} -#endif + +-- 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-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -29,11 +29,10 @@ -- -- @type 'Getter' s a = forall r. 'Getting' r s a@ -- --- But we actually hide the use of 'Const' behind a class 'Gettable' to --- report error messages from type class resolution rather than at unification --- time, where they are much uglier. +-- 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. 'Gettable' f => (a -> f a) -> s -> f s@ +-- @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 @@ -42,6 +41,15 @@ -- 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 ( @@ -52,6 +60,8 @@ -- * Building Getters , to , ito + , like + , ilike -- * Combinators for Getters and Folds , (^.) , view, views @@ -65,26 +75,25 @@ , ilistening, ilistenings -- * Implementation Details , Contravariant(..) - , coerce, coerced + , getting , Const(..) - , Gettable ) where -import Control.Applicative -import Control.Lens.Internal.Getter +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 as Writer -import Data.Functor.Contravariant -import Data.Profunctor -import Data.Profunctor.Unsafe +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 @@ -96,14 +105,14 @@ -- Getters ------------------------------------------------------------------------------- --- | Build a 'Getter' from an arbitrary Haskell function. +-- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function. -- -- @ --- 'to' f '.' 'to' g ≡ 'to' (g '.' f) +-- 'Control.Lens.Getter.to' f '.' 'Control.Lens.Getter.to' g ≡ 'Control.Lens.Getter.to' (g '.' f) -- @ -- -- @ --- a '^.' 'to' f ≡ f a +-- a '^.' 'Control.Lens.Getter.to' f ≡ f a -- @ -- -- >>> a ^.to f @@ -117,14 +126,49 @@ -- -- >>> (0, -5)^._2.to abs -- 5 -to :: (s -> a) -> IndexPreservingGetter s a -to k = dimap k coerce +-- +-- @ +-- '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 k = dimap k coerce . uncurry . indexed +-- | +-- @ +-- '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', @@ -161,7 +205,7 @@ -- at a monoidal value. -- -- @ --- 'view' '.' 'to' ≡ 'id' +-- 'view' '.' 'Control.Lens.Getter.to' ≡ 'id' -- @ -- -- >>> view (to f) a @@ -206,7 +250,7 @@ -- 'Control.Lens.Traversal.Traversal'. -- -- @ --- 'views' l f ≡ 'view' (l '.' 'to' f) +-- 'views' l f ≡ 'view' (l '.' 'Control.Lens.Getter.to' f) -- @ -- -- >>> views (to f) g a @@ -229,18 +273,18 @@ -- In a more general setting, such as when working with a 'Monad' transformer stack you can use: -- -- @ --- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a --- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a --- 'view' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> m a --- 'view' :: 'MonadReader' s m => 'Lens'' s a -> m a --- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a +-- 'views' :: 'MonadReader' s m => '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 :: (Profunctor p, MonadReader s m) => Optical p (->) (Const r) s s a a -> p a r -> m r -views l f = Reader.asks (getConst #. l (Const #. f)) +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 @@ -318,7 +362,7 @@ -- @ -- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r -- @ -uses :: (Profunctor p, MonadState s m) => Optical p (->) (Const r) s s a a -> p 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 #-} @@ -414,7 +458,7 @@ -- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf' -- @ iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r -iviews l = views l .# Indexed +iviews l f = asks (coerce l f) {-# INLINE iviews #-} -- | Use the index and value of an 'IndexedGetter' into the current state as a pair. @@ -429,7 +473,7 @@ -- -- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r -iuses l = uses l .# Indexed +iuses l f = gets (coerce l f) {-# INLINE iuses #-} -- | View the index and value of an 'IndexedGetter' or 'IndexedLens'. @@ -449,7 +493,16 @@ s ^@. l = getConst $ l (Indexed $ \i -> Const #. (,) i) s {-# INLINE (^@.) #-} --- | Coerce a 'Gettable' 'LensLike' to a 'Simple' 'LensLike'. This is useful --- when using a 'Traversal' that is not simple as a 'Getter' or a 'Fold'. -coerced :: (Functor f, Contravariant f) => LensLike f s t a b -> LensLike' f s a -coerced l f = coerce . l (coerce . f) +-- | 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 diff --git a/src/Control/Lens/Indexed.hs b/src/Control/Lens/Indexed.hs --- a/src/Control/Lens/Indexed.hs +++ b/src/Control/Lens/Indexed.hs @@ -2,23 +2,17 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- vector, hashable #endif -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(x,y,z) 1 -#endif +#include "lens-common.h" + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Indexed --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -33,15 +27,19 @@ , 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 @@ -63,6 +61,7 @@ -- * Indexed Traversables , TraversableWithIndex(..) -- * Indexed Traversable Combinators + , itraversed , ifor , imapM , iforM @@ -71,45 +70,53 @@ -- * Indexed Folds with Reified Monoid , ifoldMapBy , ifoldMapByOf + -- * Indexed Traversals with Reified Applicative + , itraverseBy + , itraverseByOf ) where -import Control.Applicative -import Control.Applicative.Backwards -import Control.Monad (void, liftM) -import Control.Monad.Trans.State.Lazy as Lazy +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.Level -import Control.Lens.Internal.Magma +import Control.Lens.Internal.Prelude import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type -import Data.Foldable -import Data.Functor.Reverse -import Data.Hashable -import Data.HashMap.Lazy as HashMap -import Data.IntMap as IntMap -import Data.List.NonEmpty as NonEmpty -import Data.Map as Map -import Data.Monoid -import Data.Profunctor.Unsafe -import Data.Sequence hiding (index) -import Data.Traversable -import Data.Tuple (swap) +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.Vector as V +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 (<.) #-} @@ -122,10 +129,26 @@ -- -- @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 @@ -134,6 +157,10 @@ -- | 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 (<.>) #-} @@ -144,24 +171,6 @@ {-# INLINE icompose #-} ------------------------------------------------------------------------------- --- Converting to Folds -------------------------------------------------------------------------------- - --- | Fold a container with indices returning both the indices and the values. --- --- The result is only valid to compose in a 'Traversal', if you don't edit the --- index as edits to the index have no effect. -withIndex :: (Indexable i p, Functor f) => Optical p (Indexed i) f s t (i, s) (j, t) -withIndex f = Indexed $ \i a -> snd <$> indexed f i (i, a) -{-# INLINE withIndex #-} - --- | When composed with an 'IndexedFold' or 'IndexedTraversal' this yields an --- ('Indexed') 'Fold' of the indices. -asIndex :: (Indexable i p, Contravariant f, Functor f) => Optical' p (Indexed i) f s i -asIndex f = Indexed $ \i _ -> coerce (indexed f i i) -{-# INLINE asIndex #-} - -------------------------------------------------------------------------------- -- Restricting by index ------------------------------------------------------------------------------- @@ -190,525 +199,94 @@ -- FunctorWithIndex ------------------------------------------------------------------------------- --- | A 'Functor' with an additional index. --- --- Instances must satisfy a modified form of the 'Functor' laws: +-- | The 'IndexedSetter' for a 'FunctorWithIndex'. -- --- @ --- 'imap' f '.' 'imap' g ≡ 'imap' (\\i -> f i '.' g i) --- 'imap' (\\_ a -> a) ≡ 'id' --- @ -class Functor f => FunctorWithIndex i f | f -> i where - -- | Map with access to the index. - imap :: (i -> a -> b) -> f a -> f b -#ifndef HLINT - default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b - imap = iover itraversed - {-# INLINE imap #-} -#endif - - -- | The 'IndexedSetter' for a 'FunctorWithIndex'. - -- - -- If you don't need access to the index, then 'mapped' is more flexible in what it accepts. - imapped :: IndexedSetter i (f a) (f b) a b - imapped = conjoined mapped (isets imap) - {-# INLINE imapped #-} +-- If you don't need access to the index, then 'mapped' is more flexible in what it accepts. +imapped :: FunctorWithIndex i f => IndexedSetter i (f a) (f b) a b +imapped = conjoined mapped (isets imap) +{-# INLINE imapped #-} ------------------------------------------------------------------------------- -- FoldableWithIndex ------------------------------------------------------------------------------- --- | A container that supports folding with an additional index. -class Foldable f => FoldableWithIndex i f | f -> i where - -- - -- | Fold a container by mapping value to an arbitrary 'Monoid' with access to the index @i@. - -- - -- When you don't need access to the index then 'foldMap' is more flexible in what it accepts. - -- - -- @ - -- 'foldMap' ≡ 'ifoldMap' '.' 'const' - -- @ - ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m -#ifndef HLINT - default ifoldMap :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m - ifoldMap = ifoldMapOf itraversed - {-# INLINE ifoldMap #-} -#endif - - -- | The 'IndexedFold' of a 'FoldableWithIndex' container. - ifolded :: IndexedFold i (f a) a - ifolded = conjoined folded $ \f -> coerce . getFolding . ifoldMap (\i -> Folding #. indexed f i) - {-# INLINE ifolded #-} - - -- | Right-associative fold of an indexed container with access to the index @i@. - -- - -- When you don't need access to the index then 'Data.Foldable.foldr' is more flexible in what it accepts. - -- - -- @ - -- 'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const' - -- @ - ifoldr :: (i -> a -> b -> b) -> b -> f a -> b - ifoldr f z t = appEndo (ifoldMap (\i -> Endo #. f i) t) z - {-# INLINE ifoldr #-} - - -- | Left-associative fold of an indexed container with access to the index @i@. - -- - -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts. - -- - -- @ - -- 'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const' - -- @ - ifoldl :: (i -> b -> a -> b) -> b -> f a -> b - ifoldl f z t = appEndo (getDual (ifoldMap (\i -> Dual #. Endo #. flip (f i)) t)) z - {-# INLINE ifoldl #-} - - -- | /Strictly/ fold right over the elements of a structure with access to the index @i@. - -- - -- When you don't need access to the index then 'foldr'' is more flexible in what it accepts. - -- - -- @ - -- 'foldr'' ≡ 'ifoldr'' '.' 'const' - -- @ - ifoldr' :: (i -> a -> b -> b) -> b -> f a -> b - ifoldr' f z0 xs = ifoldl f' id xs z0 - where f' i k x z = k $! f i x z - {-# INLINE ifoldr' #-} - - -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/. - -- - -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts. - -- - -- @ - -- 'Control.Lens.Fold.foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const' - -- @ - ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b - ifoldl' f z0 xs = ifoldr f' id xs z0 - where f' i x k z = k $! f i z x - {-# INLINE ifoldl' #-} - --- | Return whether or not any element in a container satisfies a predicate, with access to the index @i@. --- --- When you don't need access to the index then 'any' is more flexible in what it accepts. --- --- @ --- 'any' ≡ 'iany' '.' 'const' --- @ -iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool -iany f = getAny #. ifoldMap (\i -> Any #. f i) -{-# INLINE iany #-} - --- | Return whether or not all elements in a container satisfy a predicate, with access to the index @i@. --- --- When you don't need access to the index then 'all' is more flexible in what it accepts. --- --- @ --- 'all' ≡ 'iall' '.' 'const' --- @ -iall :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool -iall f = getAll #. ifoldMap (\i -> All #. f i) -{-# INLINE iall #-} - --- | Return whether or not none of the elements in a container satisfy a predicate, with access to the index @i@. --- --- When you don't need access to the index then 'none' is more flexible in what it accepts. --- --- @ --- 'none' ≡ 'inone' '.' 'const' --- 'inone' f ≡ 'not' '.' 'iany' f --- @ -inone :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool -inone f = not . iany f -{-# INLINE inone #-} - --- | Determines whether no elements of the structure satisfy the predicate. --- --- @ --- 'none' f ≡ 'not' '.' 'any' f --- @ -none :: Foldable f => (a -> Bool) -> f a -> Bool -none f = not . Data.Foldable.any f -{-# INLINE none #-} - --- | Traverse elements with access to the index @i@, discarding the results. --- --- When you don't need access to the index then 'traverse_' is more flexible in what it accepts. --- --- @ --- 'traverse_' l = 'itraverse' '.' 'const' --- @ -itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f () -itraverse_ f = getTraversed #. ifoldMap (\i -> Traversed #. void . f i) -{-# INLINE itraverse_ #-} - --- | Traverse elements with access to the index @i@, discarding the results (with the arguments flipped). --- --- @ --- 'ifor_' ≡ 'flip' 'itraverse_' --- @ --- --- When you don't need access to the index then 'for_' is more flexible in what it accepts. --- --- @ --- 'for_' a ≡ 'ifor_' a '.' 'const' --- @ -ifor_ :: (FoldableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f () -ifor_ = flip itraverse_ -{-# INLINE ifor_ #-} - --- | Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, --- discarding the results. --- --- When you don't need access to the index then 'Control.Lens.Fold.mapMOf_' is more flexible in what it accepts. --- --- @ --- 'mapM_' ≡ 'imapM' '.' 'const' --- @ -imapM_ :: (FoldableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m () -imapM_ f = getSequenced #. ifoldMap (\i -> Sequenced #. liftM skip . f i) -{-# INLINE imapM_ #-} - --- | Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, --- discarding the results (with the arguments flipped). --- --- @ --- 'iforM_' ≡ 'flip' 'imapM_' --- @ --- --- When you don't need access to the index then 'Control.Lens.Fold.forMOf_' is more flexible in what it accepts. --- --- @ --- 'Control.Lens.Fold.forMOf_' l a ≡ 'iforMOf' l a '.' 'const' --- @ -iforM_ :: (FoldableWithIndex i t, Monad m) => t a -> (i -> a -> m b) -> m () -iforM_ = flip imapM_ -{-# INLINE iforM_ #-} - --- | Concatenate the results of a function of the elements of an indexed container with access to the index. --- --- When you don't need access to the index then 'concatMap' is more flexible in what it accepts. --- --- @ --- 'concatMap' ≡ 'iconcatMap' '.' 'const' --- 'iconcatMap' ≡ 'ifoldMap' --- @ -iconcatMap :: FoldableWithIndex i f => (i -> a -> [b]) -> f a -> [b] -iconcatMap = ifoldMap -{-# INLINE iconcatMap #-} - --- | Searches a container with a predicate that is also supplied the index, returning the left-most element of the structure --- matching the predicate, or 'Nothing' if there is no such element. --- --- When you don't need access to the index then 'find' is more flexible in what it accepts. --- --- @ --- 'find' ≡ 'ifind' '.' 'const' --- @ -ifind :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Maybe (i, a) -ifind p = ifoldr (\i a y -> if p i a then Just (i, a) else y) Nothing -{-# INLINE ifind #-} - --- | Monadic fold right over the elements of a structure with an index. --- --- When you don't need access to the index then 'foldrM' is more flexible in what it accepts. --- --- @ --- 'foldrM' ≡ 'ifoldrM' '.' 'const' --- @ -ifoldrM :: (FoldableWithIndex i f, Monad m) => (i -> a -> b -> m b) -> b -> f a -> m b -ifoldrM f z0 xs = ifoldl f' return xs z0 - where f' i k x z = f i x z >>= k -{-# INLINE ifoldrM #-} - --- | Monadic fold over the elements of a structure with an index, associating to the left. --- --- When you don't need access to the index then 'foldlM' is more flexible in what it accepts. --- --- @ --- 'foldlM' ≡ 'ifoldlM' '.' 'const' --- @ -ifoldlM :: (FoldableWithIndex i f, Monad m) => (i -> b -> a -> m b) -> b -> f a -> m b -ifoldlM f z0 xs = ifoldr f' return xs z0 - where f' i x k z = f i z x >>= k -{-# INLINE ifoldlM #-} - --- | Extract the key-value pairs from a structure. +-- | The 'IndexedFold' of a 'FoldableWithIndex' container. -- --- When you don't need access to the indices in the result, then 'Data.Foldable.toList' is more flexible in what it accepts. +-- @'ifolded' '.' 'asIndex'@ is a fold over the keys of a 'FoldableWithIndex'. -- --- @ --- 'Data.Foldable.toList' ≡ 'Data.List.map' 'fst' '.' 'itoList' --- @ -itoList :: FoldableWithIndex i f => f a -> [(i,a)] -itoList = ifoldr (\i c -> ((i,c):)) [] -{-# INLINE itoList #-} +-- >>> 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 ------------------------------------------------------------------------------- --- | A 'Traversable' with an additional index. --- --- An instance must satisfy a (modified) form of the 'Traversable' laws: --- --- @ --- 'itraverse' ('const' 'Identity') ≡ 'Identity' --- 'fmap' ('itraverse' f) '.' 'itraverse' g ≡ 'Data.Functor.Compose.getCompose' '.' 'itraverse' (\\i -> 'Data.Functor.Compose.Compose' '.' 'fmap' (f i) '.' g i) --- @ -class (FunctorWithIndex i t, FoldableWithIndex i t, Traversable t) => TraversableWithIndex i t | t -> i where - -- | Traverse an indexed container. - itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b) -#ifndef HLINT - default itraverse :: Applicative f => (Int -> a -> f b) -> t a -> f (t b) - itraverse = traversed .# Indexed - {-# INLINE itraverse #-} -#endif - - -- | The 'IndexedTraversal' of a 'TraversableWithIndex' container. - itraversed :: IndexedTraversal i (t a) (t b) a b - itraversed = conjoined traverse (itraverse . indexed) - {-# INLINE itraversed #-} - --- | Traverse with an index (and the arguments flipped). --- --- @ --- 'for' a ≡ 'ifor' a '.' 'const' --- 'ifor' ≡ 'flip' 'itraverse' --- @ -ifor :: (TraversableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f (t b) -ifor = flip itraverse -{-# INLINE ifor #-} - --- | Map each element of a structure to a monadic action, --- evaluate these actions from left to right, and collect the results, with access --- the index. --- --- When you don't need access to the index 'mapM' is more liberal in what it can accept. --- --- @ --- 'mapM' ≡ 'imapM' '.' 'const' --- @ -imapM :: (TraversableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m (t b) -imapM f = unwrapMonad #. itraverse (\i -> WrapMonad #. f i) -{-# INLINE imapM #-} - --- | Map each element of a structure to a monadic action, --- evaluate these actions from left to right, and collect the results, with access --- its position (and the arguments flipped). --- --- @ --- 'forM' a ≡ 'iforM' a '.' 'const' --- 'iforM' ≡ 'flip' 'imapM' --- @ -iforM :: (TraversableWithIndex i t, Monad m) => t a -> (i -> a -> m b) -> m (t b) -iforM = flip imapM -{-# INLINE iforM #-} - --- | Generalizes 'Data.Traversable.mapAccumR' to add access to the index. --- --- 'imapAccumROf' accumulates state from right to left. --- --- @ --- 'Control.Lens.Traversal.mapAccumR' ≡ 'imapAccumR' '.' 'const' --- @ -imapAccumR :: TraversableWithIndex i t => (i -> s -> a -> (s, b)) -> s -> t a -> (s, t b) -imapAccumR f s0 a = swap (Lazy.runState (forwards (itraverse (\i c -> Backwards (Lazy.state (\s -> swap (f i s c)))) a)) s0) -{-# INLINE imapAccumR #-} - --- | Generalizes 'Data.Traversable.mapAccumL' to add access to the index. --- --- 'imapAccumLOf' accumulates state from left to right. --- --- @ --- 'Control.Lens.Traversal.mapAccumLOf' ≡ 'imapAccumL' '.' 'const' --- @ -imapAccumL :: TraversableWithIndex i t => (i -> s -> a -> (s, b)) -> s -> t a -> (s, t b) -imapAccumL f s0 a = swap (Lazy.runState (itraverse (\i c -> Lazy.state (\s -> swap (f i s c))) a) s0) -{-# INLINE imapAccumL #-} +-- | 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 ------------------------------------------------------------------------------- -instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where - imap f = Backwards . imap f . forwards - {-# INLINE imap #-} - -instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where - ifoldMap f = ifoldMap f . forwards - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where - itraverse f = fmap Backwards . itraverse f . forwards - {-# INLINE itraverse #-} - -instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where - imap f = Reverse . imap f . getReverse - {-# INLINE imap #-} - -instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where - ifoldMap f = getDual . ifoldMap (\i -> Dual #. f i) . getReverse - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where - itraverse f = fmap Reverse . forwards . itraverse (\i -> Backwards . f i) . getReverse - {-# INLINE itraverse #-} - -instance FunctorWithIndex () Identity where - imap f (Identity a) = Identity (f () a) - {-# INLINE imap #-} - -instance FoldableWithIndex () Identity where - ifoldMap f (Identity a) = f () a - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex () Identity where - itraverse f (Identity a) = Identity <$> f () a - {-# INLINE itraverse #-} - -instance FunctorWithIndex k ((,) k) where - imap f (k,a) = (k, f k a) - {-# INLINE imap #-} - -instance FoldableWithIndex k ((,) k) where - ifoldMap = uncurry - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex k ((,) k) where - itraverse f (k, a) = (,) k <$> f k a - {-# INLINE itraverse #-} - --- | The position in the list is available as the index. -instance FunctorWithIndex Int [] -instance FoldableWithIndex Int [] -instance TraversableWithIndex Int [] where - itraverse = itraverseOf traversed - {-# INLINE itraverse #-} - -instance FunctorWithIndex Int NonEmpty -instance FoldableWithIndex Int NonEmpty -instance TraversableWithIndex Int NonEmpty where - itraverse = itraverseOf traversed - {-# INLINE itraverse #-} - -instance FunctorWithIndex () Maybe where - imap f = fmap (f ()) - {-# INLINE imap #-} -instance FoldableWithIndex () Maybe where - ifoldMap f = foldMap (f ()) - {-# INLINE ifoldMap #-} -instance TraversableWithIndex () Maybe where - itraverse f = traverse (f ()) - {-# INLINE itraverse #-} - --- | The position in the 'Seq' is available as the index. -instance FunctorWithIndex Int Seq -instance FoldableWithIndex Int Seq -instance TraversableWithIndex Int Seq where - itraverse = itraverseOf traversed - {-# INLINE itraverse #-} - -instance FunctorWithIndex Int Vector where - imap = V.imap - {-# INLINE imap #-} -instance FoldableWithIndex Int Vector where - ifoldr = V.ifoldr - {-# INLINE ifoldr #-} - ifoldl = V.ifoldl . flip - {-# INLINE ifoldl #-} - ifoldr' = V.ifoldr' - {-# INLINE ifoldr' #-} - ifoldl' = V.ifoldl' . flip - {-# INLINE ifoldl' #-} -instance TraversableWithIndex Int Vector where - itraverse f = sequenceA . V.imap f - {-# INLINE itraverse #-} - -instance FunctorWithIndex Int IntMap -instance FoldableWithIndex Int IntMap -instance TraversableWithIndex Int IntMap where -#if MIN_VERSION_containers(0,5,0) - itraverse = IntMap.traverseWithKey -#else - itraverse f = sequenceA . IntMap.mapWithKey f -#endif - {-# INLINE itraverse #-} - -instance FunctorWithIndex k (Map k) -instance FoldableWithIndex k (Map k) -instance TraversableWithIndex k (Map k) where -#if MIN_VERSION_containers(0,5,0) - itraverse = Map.traverseWithKey -#else - itraverse f = sequenceA . Map.mapWithKey f -#endif - {-# INLINE itraverse #-} - -instance (Eq k, Hashable k) => FunctorWithIndex k (HashMap k) -instance (Eq k, Hashable k) => FoldableWithIndex k (HashMap k) -instance (Eq k, Hashable k) => TraversableWithIndex k (HashMap k) where - itraverse = HashMap.traverseWithKey - {-# INLINE itraverse #-} - -instance FunctorWithIndex r ((->) r) where - imap f g x = f x (g x) - {-# INLINE imap #-} - -instance FunctorWithIndex i (Level i) where - imap f = go where - go (Two n l r) = Two n (go l) (go r) - go (One i a) = One i (f i a) - go Zero = Zero - {-# INLINE imap #-} - -instance FoldableWithIndex i (Level i) where - ifoldMap f = go where - go (Two _ l r) = go l `mappend` go r - go (One i a) = f i a - go Zero = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i (Level i) where - itraverse f = go where - go (Two n l r) = Two n <$> go l <*> go r - go (One i a) = One i <$> f i a - go Zero = pure Zero - {-# INLINE itraverse #-} +{-# 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; + #-} -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 #-} +{-# 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; + #-} -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 #-} +{-# 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; + #-} -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 #-} +{-# 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; + #-} -------------------------------------------------------------------------------- --- Misc. -------------------------------------------------------------------------------- +{-# 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; + #-} -skip :: a -> () -skip _ = () -{-# INLINE skip #-} +{-# 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 = reifyFold f z (ifoldMap (\i a -> M (g i a))) +ifoldMapBy f z g = reifyMonoid f z (ifoldMap (\i a -> ReflectedMonoid (g i a))) -ifoldMapByOf :: (forall s. IndexedGetting i (M r s) t a) -> (r -> r -> r) -> r -> (i -> a -> r) -> t -> r -ifoldMapByOf l f z g = reifyFold f z (ifoldMapOf l (\i a -> M (g i a))) +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))) diff --git a/src/Control/Lens/Internal.hs b/src/Control/Lens/Internal.hs --- a/src/Control/Lens/Internal.hs +++ b/src/Control/Lens/Internal.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -14,8 +13,7 @@ -- ---------------------------------------------------------------------------- module Control.Lens.Internal - ( module Control.Lens.Internal.Action - , module Control.Lens.Internal.Bazaar + ( module Control.Lens.Internal.Bazaar , module Control.Lens.Internal.Context , module Control.Lens.Internal.Fold , module Control.Lens.Internal.Getter @@ -29,7 +27,6 @@ , module Control.Lens.Internal.Zoom ) where -import Control.Lens.Internal.Action import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Fold @@ -43,7 +40,3 @@ import Control.Lens.Internal.Review import Control.Lens.Internal.Setter import Control.Lens.Internal.Zoom - -#ifdef HLINT -{-# ANN module "HLint: ignore Use import/export shortcut" #-} -#endif diff --git a/src/Control/Lens/Internal/Action.hs b/src/Control/Lens/Internal/Action.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/Action.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.Internal.Action --- Copyright : (C) 2012-2014 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Control.Lens.Internal.Action - ( - -- ** Actions - Effective(..) - , Effect(..) - ) where - -import Control.Applicative -import Control.Applicative.Backwards -import Control.Monad -import Data.Functor.Bind -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.Profunctor.Unsafe -import Data.Semigroup - -------------------------------------------------------------------------------- --- Programming with Effects -------------------------------------------------------------------------------- - --- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a 'Monad' wrapped around a value. --- --- That said, the 'Monad' is possibly rather unrelated to any 'Applicative' structure. -class (Monad m, Functor f, Contravariant f) => Effective m r f | f -> m r where - effective :: m r -> f a - ineffective :: f a -> m r - -instance Effective m r f => Effective m (Dual r) (Backwards f) where - effective = Backwards . effective . liftM getDual - {-# INLINE effective #-} - ineffective = liftM Dual . ineffective . forwards - {-# INLINE ineffective #-} - -instance Effective Identity r (Const r) where - effective = Const #. runIdentity - {-# INLINE effective #-} - ineffective = Identity #. getConst - {-# INLINE ineffective #-} - ------------------------------------------------------------------------------- --- 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 => Effective m r (Effect m r) where - effective = Effect - {-# INLINE effective #-} - ineffective = getEffect - {-# INLINE ineffective #-} - -instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where - Effect ma <> Effect mb = Effect (liftF2 (<>) ma mb) - {-# INLINE (<>) #-} - -instance (Monad m, Monoid r) => Monoid (Effect m r a) where - mempty = Effect (return mempty) - {-# INLINE mempty #-} - Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) - {-# INLINE mappend #-} - -instance (Apply m, Semigroup r) => Apply (Effect m r) where - Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb) - {-# INLINE (<.>) #-} - -instance (Monad m, Monoid r) => Applicative (Effect m r) where - pure _ = Effect (return mempty) - {-# INLINE pure #-} - Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) - {-# INLINE (<*>) #-} diff --git a/src/Control/Lens/Internal/Bazaar.hs b/src/Control/Lens/Internal/Bazaar.hs --- a/src/Control/Lens/Internal/Bazaar.hs +++ b/src/Control/Lens/Internal/Bazaar.hs @@ -1,19 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Bazaar --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -29,21 +26,17 @@ , BazaarT1(..), BazaarT1' ) where -import Control.Applicative +import Prelude () + import Control.Arrow as Arrow -import Control.Category +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.Functor.Compose -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.Semigroup -import Data.Profunctor +import Data.Kind import Data.Profunctor.Rep -import Data.Profunctor.Unsafe -import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- Bizarre @@ -90,11 +83,11 @@ instance Conjoined p => IndexedComonad (Bazaar p) where iextract (Bazaar m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} - iduplicate (Bazaar m) = getCompose $ m (Compose #. distrib sell . sell) + 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 (corep k w) + sell = cotabulate $ \ w -> Bazaar $ tabulate $ \k -> pure (cosieve k w) {-# INLINE sell #-} instance Profunctor p => Bizarre p (Bazaar p) where @@ -104,16 +97,30 @@ 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 - Bazaar mf <.> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb + (<.>) = (<*>) {-# 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 @@ -124,6 +131,10 @@ instance (a ~ b, Conjoined p) => ComonadApply (Bazaar p a b) where (<@>) = (<*>) {-# INLINE (<@>) #-} + (@>) = (*>) + {-# INLINE (@>) #-} + (<@) = (<*) + {-# INLINE (<@) #-} ------------------------------------------------------------------------------ -- BazaarT @@ -134,10 +145,8 @@ -- -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! -newtype BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } -#if __GLASGOW_HASKELL__ >= 707 +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 -#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. -- @@ -153,11 +162,11 @@ instance Conjoined p => IndexedComonad (BazaarT p g) where iextract (BazaarT m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} - iduplicate (BazaarT m) = getCompose $ m (Compose #. distrib sell . sell) + 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 (`corep` w) + sell = cotabulate $ \ w -> BazaarT (`cosieve` w) {-# INLINE sell #-} instance Profunctor p => Bizarre p (BazaarT p g) where @@ -167,16 +176,30 @@ 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 - BazaarT mf <.> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb + (<.>) = (<*>) {-# 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 @@ -187,6 +210,10 @@ 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") @@ -199,8 +226,10 @@ 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 ------------------------------------------------------------------------------ @@ -246,11 +275,11 @@ instance Conjoined p => IndexedComonad (Bazaar1 p) where iextract (Bazaar1 m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} - iduplicate (Bazaar1 m) = getCompose $ m (Compose #. distrib sell . sell) + 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 (corep k w) + sell = cotabulate $ \ w -> Bazaar1 $ tabulate $ \k -> pure (cosieve k w) {-# INLINE sell #-} instance Profunctor p => Bizarre1 p (Bazaar1 p) where @@ -260,10 +289,16 @@ 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 @@ -272,8 +307,12 @@ {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where - Bazaar1 mf <@> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb + (<@>) = (<.>) {-# INLINE (<@>) #-} + (@>) = (.>) + {-# INLINE (@>) #-} + (<@) = (<.) + {-# INLINE (<@) #-} ------------------------------------------------------------------------------ -- BazaarT1 @@ -284,10 +323,8 @@ -- -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! -newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t } -#if __GLASGOW_HASKELL__ >= 707 +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 -#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. -- @@ -303,11 +340,11 @@ instance Conjoined p => IndexedComonad (BazaarT1 p g) where iextract (BazaarT1 m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} - iduplicate (BazaarT1 m) = getCompose $ m (Compose #. distrib sell . sell) + 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 (`corep` w) + sell = cotabulate $ \ w -> BazaarT1 (`cosieve` w) {-# INLINE sell #-} instance Profunctor p => Bizarre1 p (BazaarT1 p g) where @@ -317,10 +354,16 @@ 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 @@ -329,8 +372,12 @@ {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where - BazaarT1 mf <@> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb + (<@>) = (<.>) {-# INLINE (<@>) #-} + (@>) = (.>) + {-# INLINE (@>) #-} + (<@) = (<.) + {-# INLINE (<@) #-} instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where contramap _ = (<$) (error "contramap: BazaarT1") diff --git a/src/Control/Lens/Internal/ByteString.hs b/src/Control/Lens/Internal/ByteString.hs --- a/src/Control/Lens/Internal/ByteString.hs +++ b/src/Control/Lens/Internal/ByteString.hs @@ -3,13 +3,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} #endif + +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -20,142 +23,164 @@ -- Haskell Platforms and to improve constant and asymptotic factors in our performance. ---------------------------------------------------------------------------- module Control.Lens.Internal.ByteString - ( unpackStrict, traversedStrict, traversedStrictTree - , unpackStrict8, traversedStrict8, traversedStrictTree8 - , unpackLazy, traversedLazy - , unpackLazy8, traversedLazy8 + ( traversedStrictTree, traversedStrictTree8 + , traversedLazy, traversedLazy8 ) where -import Control.Applicative -import Control.Lens +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.Internal as BLI 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 -#if MIN_VERSION_base(4,4,0) -import Foreign.ForeignPtr.Safe -import Foreign.ForeignPtr.Unsafe -#else import Foreign.ForeignPtr -#endif import GHC.Base (unsafeChr) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) import GHC.IO (unsafeDupablePerformIO) --- | Traverse a strict 'B.ByteString' from left to right in a biased fashion. -traversedStrict :: Int -> IndexedTraversal' Int B.ByteString Word8 -traversedStrict i0 pafb (BI.PS fp off len) = - let p = unsafeForeignPtrToPtr fp - in fmap (rebuild len) (go i0 (p `plusPtr` off) (p `plusPtr` (off+len))) - where - rebuild n = \xs -> unsafeCreate n $ \p -> go2 p xs - go2 !p (x:xs) = poke p x >> go2 (p `plusPtr` 1) xs - go2 _ [] = return () - -- TODO: use a balanced tree (up to some grain size) - go !i !p !q - | p == q = pure [] - | otherwise = let !x = BI.inlinePerformIO $ do - x' <- peek p - touchForeignPtr fp - return x' - in (:) <$> indexed pafb (i :: Int) x <*> go (i + 1) (p `plusPtr` 1) q -{-# INLINE traversedStrict #-} - --- | Traverse a strict 'B.ByteString' from left to right in a biased fashion --- pretending the bytes are characters. -traversedStrict8 :: Int -> IndexedTraversal' Int B.ByteString Char -traversedStrict8 i0 pafb (BI.PS fp off len) = - let p = unsafeForeignPtrToPtr fp - in fmap (rebuild len) (go i0 (p `plusPtr` off) (p `plusPtr` (off+len))) - where - rebuild n = \xs -> unsafeCreate n $ \p -> go2 p xs - go2 !p (x:xs) = poke p (c2w x) >> go2 (p `plusPtr` 1) xs - go2 _ [] = return () - -- TODO: use a balanced tree (up to some grain size) - go !i !p !q - | p == q = pure [] - | otherwise = let !x = BI.inlinePerformIO $ do - x' <- peek p - touchForeignPtr fp - return x' - in (:) <$> indexed pafb (i :: Int) (w2c x) <*> go (i + 1) (p `plusPtr` 1) q -{-# INLINE traversedStrict8 #-} - grain :: Int grain = 32 {-# INLINE grain #-} -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of -- elements at the leaves. -traversedStrictTree :: Int -> IndexedTraversal' Int B.ByteString Word8 -traversedStrictTree i0 pafb (BI.PS fp off len) = rebuild len <$> go (unsafeForeignPtrToPtr fp `plusPtr` (off - i0)) i0 (i0 + len) +traversedStrictTree :: IndexedTraversal' Int B.ByteString Word8 +traversedStrictTree pafb bs = unsafeCreate len <$> go 0 len where - rebuild n f = unsafeCreate n $ \q -> f $! (q `plusPtr` (off - i0)) - go !p !i !j - | i + grain < j, k <- i + shiftR (j - i) 1 = (\l r q -> l q >> r q) <$> go p i k <*> go p k j - | otherwise = run p i j - run !p !i !j + 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 = BI.inlinePerformIO $ do - x' <- peekByteOff p i - touchForeignPtr fp - return x' - in (\y ys !q -> pokeByteOff q i y >> ys q) <$> indexed pafb (i :: Int) x <*> run p (i + 1) j -{-# INLINE traversedStrictTree #-} + | 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 :: Int -> IndexedTraversal' Int B.ByteString Char -traversedStrictTree8 i0 pafb (BI.PS fp off len) = rebuild len <$> go i0 (i0 + len) +traversedStrictTree8 :: IndexedTraversal' Int B.ByteString Char +traversedStrictTree8 pafb bs = unsafeCreate len <$> go 0 len where - p = unsafeForeignPtrToPtr fp `plusPtr` (off - i0) - rebuild n f = unsafeCreate n $ \q -> f (q `plusPtr` (off - i0)) + 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 + | 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 = BI.inlinePerformIO $ do - x' <- peekByteOff p i - touchForeignPtr fp - return x' - in (\y ys q -> poke (q `plusPtr` i) (c2w y) >> ys q) <$> indexed pafb (i :: Int) (w2c x) <*> run (i + 1) j -{-# INLINE traversedStrictTree8 #-} + | 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 #-} --- | Unpack a lazy 'Bytestring' -unpackLazy :: BL.ByteString -> [Word8] -unpackLazy = BL.unpack -{-# INLINE unpackLazy #-} +{-# 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 = go 0 where - go _ BLI.Empty = pure BLI.Empty - go i (BLI.Chunk b bs) = BLI.Chunk <$> reindexed (fromIntegral :: Int -> Int64) (traversedStrictTree (fromIntegral i)) pafb b <*> go i' bs - where !i' = i + B.length b -{-# INLINE traversedLazy #-} +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; + #-} --- | Unpack a lazy 'BL.ByteString' pretending the bytes are chars. -unpackLazy8 :: BL.ByteString -> String -unpackLazy8 = BL8.unpack -{-# INLINE unpackLazy8 #-} +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 = go 0 where - go _ BLI.Empty = pure BLI.Empty - go i (BLI.Chunk b bs) = BLI.Chunk <$> reindexed (fromIntegral :: Int -> Int64) (traversedStrictTree8 (fromIntegral i)) pafb b <*> go i' bs - where !i' = i + B.length b -{-# INLINE traversedLazy8 #-} +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 ------------------------------------------------------------------------------ @@ -172,39 +197,6 @@ c2w = fromIntegral . ord {-# INLINE c2w #-} --- TODO: Should this create the list in chunks, like unpackBytes does in 0.10? - --- | Unpack a strict 'B.Bytestring' -unpackStrict :: B.ByteString -> [Word8] -unpackStrict (BI.PS fp off len) = - let p = unsafeForeignPtrToPtr fp - in go (p `plusPtr` off) (p `plusPtr` (off+len)) - where - go !p !q | p == q = [] - | otherwise = let !x = BI.inlinePerformIO $ do - x' <- peek p - touchForeignPtr fp - return x' - in x : go (p `plusPtr` 1) q -{-# INLINE unpackStrict #-} - --- TODO: Should this create the list in chunks, like unpackBytes does in 0.10? - --- | Unpack a strict 'B.Bytestring', pretending the bytes are chars. -unpackStrict8 :: B.ByteString -> String -unpackStrict8 (BI.PS fp off len) = - let p = unsafeForeignPtrToPtr fp - in go (p `plusPtr` off) (p `plusPtr` (off+len)) - where - go !p !q | p == q = [] - | otherwise = let !x = BI.inlinePerformIO $ do - x' <- peek p - touchForeignPtr fp - return x' - in w2c x : go (p `plusPtr` 1) q -{-# INLINE unpackStrict8 #-} - - -- | A way of creating ByteStrings outside the IO monad. The @Int@ -- argument gives the final size of the ByteString. Unlike -- 'createAndTrim' the ByteString is not reallocated if the final size @@ -218,5 +210,9 @@ 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 #-} diff --git a/src/Control/Lens/Internal/CTypes.hs b/src/Control/Lens/Internal/CTypes.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/CTypes.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- | +-- 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) diff --git a/src/Control/Lens/Internal/Context.hs b/src/Control/Lens/Internal/Context.hs --- a/src/Control/Lens/Internal/Context.hs +++ b/src/Control/Lens/Internal/Context.hs @@ -1,21 +1,15 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Context --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -32,18 +26,16 @@ , PretextT(..), PretextT' ) where -import Control.Applicative +import Prelude () + import Control.Arrow -import Control.Category +import qualified Control.Category as C import Control.Comonad import Control.Comonad.Store.Class import Control.Lens.Internal.Indexed -import Data.Functor.Compose -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.Profunctor +import Control.Lens.Internal.Prelude +import Data.Kind import Data.Profunctor.Rep -import Data.Profunctor.Unsafe import Prelude hiding ((.),id) ------------------------------------------------------------------------------ @@ -70,6 +62,8 @@ -- "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 @@ -134,7 +128,7 @@ ------------------------------------------------------------------------------ -- | The indexed store can be used to characterize a 'Control.Lens.Lens.Lens' --- and is used by 'Control.Lens.Lens.clone'. +-- 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 }@, @@ -229,7 +223,7 @@ instance Conjoined p => IndexedComonad (Pretext p) where iextract (Pretext m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} - iduplicate (Pretext m) = getCompose $ m (Compose #. distrib sell . sell) + iduplicate (Pretext m) = getCompose $ m (Compose #. distrib sell C.. sell) {-# INLINE iduplicate #-} instance (a ~ b, Conjoined p) => Comonad (Pretext p a b) where @@ -269,7 +263,7 @@ {-# INLINE experiment #-} instance Corepresentable p => Sellable p (Pretext p) where - sell = cotabulate $ \ w -> Pretext (`corep` w) + sell = cotabulate $ \ w -> Pretext (`cosieve` w) {-# INLINE sell #-} ------------------------------------------------------------------------------ @@ -282,17 +276,16 @@ -- impact on its performance, and which permits the use of an arbitrary 'Conjoined' -- 'Profunctor'. -- --- The extra phantom 'Functor' is used to let us lie and claim a 'Gettable' instance under --- limited circumstances. This is used internally to permit a number of combinators to --- gracefully degrade when applied to a 'Control.Lens.Fold.Fold', 'Control.Lens.Getter.Getter' --- or 'Control.Lens.Action.Action'. -newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } +-- 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 } -#if __GLASGOW_HASKELL__ >= 707 -- 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 -#endif -- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@ type PretextT' p g a = PretextT p g a a @@ -308,7 +301,7 @@ instance Conjoined p => IndexedComonad (PretextT p g) where iextract (PretextT m) = runIdentity $ m (arr Identity) {-# INLINE iextract #-} - iduplicate (PretextT m) = getCompose $ m (Compose #. distrib sell . sell) + iduplicate (PretextT m) = getCompose $ m (Compose #. distrib sell C.. sell) {-# INLINE iduplicate #-} instance (a ~ b, Conjoined p) => Comonad (PretextT p g a b) where @@ -348,7 +341,7 @@ {-# INLINE experiment #-} instance Corepresentable p => Sellable p (PretextT p g) where - sell = cotabulate $ \ w -> PretextT (`corep` w) + sell = cotabulate $ \ w -> PretextT (`cosieve` w) {-# INLINE sell #-} instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where @@ -362,5 +355,5 @@ -- | We can convert any 'Conjoined' 'Profunctor' to a function, -- possibly losing information about an index in the process. coarr :: (Representable q, Comonad (Rep q)) => q a b -> a -> b -coarr qab = extract . rep qab +coarr qab = extract . sieve qab {-# INLINE coarr #-} diff --git a/src/Control/Lens/Internal/Deque.hs b/src/Control/Lens/Internal/Deque.hs --- a/src/Control/Lens/Internal/Deque.hs +++ b/src/Control/Lens/Internal/Deque.hs @@ -3,13 +3,12 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif + +#include "lens-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Deque --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -25,34 +24,35 @@ , singleton ) where -import Control.Applicative +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 as Foldable +import Data.Foldable (toList) import Data.Function import Data.Functor.Bind import Data.Functor.Plus import Data.Functor.Reverse -import Data.Traversable as Traversable -import Data.Semigroup -import Data.Profunctor.Unsafe -import Prelude hiding (null) +-- $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 of a 'Deque' is 'empty'. +-- | /O(1)/. Determine if a 'Deque' is 'empty'. -- --- >>> null empty +-- >>> Control.Lens.Internal.Deque.null empty -- True -- --- >>> null (singleton 1) +-- >>> Control.Lens.Internal.Deque.null (singleton 1) -- False null :: Deque a -> Bool null (BD lf _ lr _) = lf + lr == 0 @@ -79,7 +79,7 @@ -- >>> fromList [1,2] -- BD 1 [1] 1 [2] fromList :: [a] -> Deque a -fromList = Prelude.foldr cons empty +fromList = foldr cons empty {-# INLINE fromList #-} instance Eq a => Eq (Deque a) where @@ -110,8 +110,8 @@ instance Alt Deque where xs ys - | size xs < size ys = Foldable.foldr cons ys xs - | otherwise = Foldable.foldl snoc xs ys + | size xs < size ys = foldr cons ys xs + | otherwise = foldl snoc xs ys {-# INLINE () #-} instance Plus Deque where @@ -122,8 +122,8 @@ empty = BD 0 [] 0 [] {-# INLINE empty #-} xs <|> ys - | size xs < size ys = Foldable.foldr cons ys xs - | otherwise = Foldable.foldl snoc xs ys + | size xs < size ys = foldr cons ys xs + | otherwise = foldl snoc xs ys {-# INLINE (<|>) #-} instance Reversing (Deque a) where @@ -135,7 +135,7 @@ {-# INLINE (>>-) #-} instance Monad Deque where - return a = BD 1 [a] 0 [] + return = pure {-# INLINE return #-} ma >>= k = fromList (toList ma >>= toList . k) {-# INLINE (>>=) #-} @@ -166,17 +166,19 @@ instance Semigroup (Deque a) where xs <> ys - | size xs < size ys = Foldable.foldr cons ys xs - | otherwise = Foldable.foldl snoc 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 = Foldable.foldr cons ys xs - | otherwise = Foldable.foldl snoc 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 @@ -191,7 +193,9 @@ if lf + lr == 0 then Left empty else Right $ case f of - [] -> (head r, empty) + [] -> 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 #-} @@ -200,6 +204,8 @@ if lf + lr == 0 then Left empty else Right $ case r of - [] -> (empty, head f) + [] -> 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 #-} diff --git a/src/Control/Lens/Internal/Doctest.hs b/src/Control/Lens/Internal/Doctest.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/Doctest.hs @@ -0,0 +1,43 @@ +-- | 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" diff --git a/src/Control/Lens/Internal/Exception.hs b/src/Control/Lens/Internal/Exception.hs --- a/src/Control/Lens/Internal/Exception.hs +++ b/src/Control/Lens/Internal/Exception.hs @@ -1,28 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} -#endif -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Exception --- Copyright : (C) 2013-2014 Edward Kmett +-- Copyright : (C) 2013-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -39,17 +30,13 @@ import Control.Exception as Exception import Control.Lens.Fold import Control.Lens.Getter -import Control.Lens.Internal.Reflection import Control.Monad.Catch as Catch +import Data.Kind import Data.Monoid import Data.Proxy +import Data.Reflection import Data.Typeable --- This is needed because ghc 7.8-rc2 has Typeable1 as a type alias. -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 -#define Typeable1 Typeable -#endif - ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------ @@ -58,7 +45,7 @@ -- -- This lets us write combinators to build handlers that are agnostic about the choice of -- which of these they use. -class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where +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). -- -- @ @@ -143,13 +130,13 @@ instance Handleable SomeException IO Exception.Handler where handler = handlerIO -instance Typeable1 m => Handleable SomeException m (Catch.Handler m) where +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, Typeable1 m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r +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) ------------------------------------------------------------------------------ @@ -157,7 +144,7 @@ ------------------------------------------------------------------------------ -- | There was an 'Exception' caused by abusing the internals of a 'Handler'. -data HandlingException = HandlingException deriving (Show,Typeable) +data HandlingException = HandlingException deriving Show instance Exception HandlingException @@ -171,33 +158,20 @@ -} -- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does. -newtype Handling a s (m :: * -> *) = Handling a -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 - deriving Typeable +newtype Handling a s (m :: Type -> Type) = Handling a type role Handling representational nominal nominal -#else --- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap. --- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep. -instance (Typeable a, Typeable s, Typeable1 m) => Typeable (Handling a s m) where - typeOf _ = mkTyConApp handlingTyCon [typeOf (undefined :: a), typeOf (undefined :: s), typeOf1 (undefined :: m a)] - {-# INLINE typeOf #-} -handlingTyCon :: TyCon -#if MIN_VERSION_base(4,4,0) -handlingTyCon = mkTyCon3 "lens" "Control.Lens.Internal.Exception" "Handling" -#else -handlingTyCon = mkTyCon "Control.Lns.Internal.Exception.Handling" -#endif -{-# NOINLINE handlingTyCon #-} -#endif - -- The @Handling@ wrapper is uninteresting, and should never be thrown, so you won't get much benefit here. instance Show (Handling a s m) where showsPrec d _ = showParen (d > 10) $ showString "Handling ..." {-# INLINE showsPrec #-} -instance (Reifies s (SomeException -> Maybe a), Typeable a, Typeable1 m, Typeable s) => Exception (Handling a s m) where +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) diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -0,0 +1,691 @@ +{-# 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 diff --git a/src/Control/Lens/Internal/Fold.hs b/src/Control/Lens/Internal/Fold.hs --- a/src/Control/Lens/Internal/Fold.hs +++ b/src/Control/Lens/Internal/Fold.hs @@ -2,13 +2,12 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Fold --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -20,24 +19,24 @@ -- * Monoids for folding Folding(..) , Traversed(..) + , TraversedF(..) , Sequenced(..) - , Max(..), getMax - , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost - , ReifiedMonoid(..), M(..) - , reifyFold + , ReifiedMonoid(..) + -- * Semigroups for folding + , NonEmptyDList(..) ) where -import Control.Applicative +import Prelude () + import Control.Lens.Internal.Getter +import Control.Lens.Internal.Prelude import Data.Functor.Bind -import Data.Functor.Contravariant -import Data.Maybe -import Data.Semigroup hiding (Min, getMin, Max, getMax) +import Data.Maybe (fromMaybe) import Data.Reflection -{-# ANN module "HLint: ignore Avoid lambda" #-} +import qualified Data.List.NonEmpty as NonEmpty ------------------------------------------------------------------------------ -- Folding @@ -46,15 +45,17 @@ -- | A 'Monoid' for a 'Contravariant' 'Applicative'. newtype Folding f a = Folding { getFolding :: f a } -instance (Contravariant f, Apply f) => Semigroup (Folding f a) where - Folding fr <> Folding fs = Folding (fr .> fs) +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 @@ -65,115 +66,101 @@ -- The argument 'a' of the result should not be used! newtype Traversed a f = Traversed { getTraversed :: f a } -instance Apply f => Semigroup (Traversed a f) where - Traversed ma <> Traversed mb = Traversed (ma .> mb) +-- 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 ------------------------------------------------------------------------------ --- Sequenced +-- TraversedF ------------------------------------------------------------------------------ --- | Used internally by 'Control.Lens.Traversal.mapM_' and the like. +-- | Used internally by 'Control.Lens.Fold.traverse1Of_' and the like. -- --- The argument 'a' of the result should not be used! -newtype Sequenced a m = Sequenced { getSequenced :: m a } +-- @since 4.16 +newtype TraversedF a f = TraversedF { getTraversedF :: f a } -instance Apply m => Semigroup (Sequenced a m) where - Sequenced ma <> Sequenced mb = Sequenced (ma .> mb) +instance Apply f => Semigroup (TraversedF a f) where + TraversedF ma <> TraversedF mb = TraversedF (ma .> mb) {-# INLINE (<>) #-} -instance Monad m => Monoid (Sequenced a m) where - mempty = Sequenced (return (error "Sequenced: value used")) +instance (Apply f, Applicative f) => Monoid (TraversedF a f) where + mempty = TraversedF (pure (error "TraversedF: value used")) {-# INLINE mempty #-} - Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) +#if !(MIN_VERSION_base(4,11,0)) + TraversedF ma `mappend` TraversedF mb = TraversedF (ma *> mb) {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ --- Min +-- Sequenced ------------------------------------------------------------------------------ --- | Used for 'Control.Lens.Fold.minimumOf'. -data Min a = NoMin | Min a +-- | 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 Ord a => Semigroup (Min a) where - NoMin <> m = m - m <> NoMin = m - Min a <> Min b = Min (min a b) +instance Monad m => Semigroup (Sequenced a m) where + Sequenced ma <> Sequenced mb = Sequenced (ma >> mb) {-# INLINE (<>) #-} -instance Ord a => Monoid (Min a) where - mempty = NoMin +instance Monad m => Monoid (Sequenced a m) where + mempty = Sequenced (return (error "Sequenced: value used")) {-# INLINE mempty #-} - mappend NoMin m = m - mappend m NoMin = m - mappend (Min a) (Min b) = Min (min a b) +#if !(MIN_VERSION_base(4,11,0)) + Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) {-# INLINE mappend #-} - --- | Obtain the minimum. -getMin :: Min a -> Maybe a -getMin NoMin = Nothing -getMin (Min a) = Just a -{-# INLINE getMin #-} +#endif ------------------------------------------------------------------------------ --- Max +-- NonEmptyDList ------------------------------------------------------------------------------ --- | Used for 'Control.Lens.Fold.maximumOf'. -data Max a = NoMax | Max a - -instance Ord a => Semigroup (Max a) where - NoMax <> m = m - m <> NoMax = m - Max a <> Max b = Max (max a b) - {-# INLINE (<>) #-} - -instance Ord a => Monoid (Max a) where - mempty = NoMax - {-# INLINE mempty #-} - mappend NoMax m = m - mappend m NoMax = m - mappend (Max a) (Max b) = Max (max a b) - {-# INLINE mappend #-} +newtype NonEmptyDList a + = NonEmptyDList { getNonEmptyDList :: [a] -> NonEmpty.NonEmpty a } --- | Obtain the maximum. -getMax :: Max a -> Maybe a -getMax NoMax = Nothing -getMax (Max a) = Just a -{-# INLINE getMax #-} +instance Semigroup (NonEmptyDList a) where + NonEmptyDList f <> NonEmptyDList g = NonEmptyDList (f . NonEmpty.toList . g) ------------------------------------------------------------------------------ -- Leftmost and Rightmost ------------------------------------------------------------------------------ --- | Used for 'Control.Lens.Fold.preview'. +-- | Used for 'Control.Lens.Fold.firstOf'. data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) instance Semigroup (Leftmost a) where - (<>) = mappend - {-# INLINE (<>) #-} - -instance Monoid (Leftmost a) where - mempty = LPure - {-# INLINE mempty #-} - mappend x y = LStep $ case x of + x <> y = LStep $ case x of LPure -> y LLeaf _ -> x LStep x' -> case y of -- The last two cases make firstOf produce a Just as soon as any element -- is encountered, and possibly serve as a micro-optimisation; this - -- behaviour can be disabled by replacing them with _ -> mappend x y'. + -- 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 @@ -185,48 +172,29 @@ data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) instance Semigroup (Rightmost a) where - (<>) = mappend - {-# INLINE (<>) #-} - -instance Monoid (Rightmost a) where - mempty = RPure - {-# INLINE mempty #-} - mappend x y = RStep $ case y of + x <> y = RStep $ case y of RPure -> x RLeaf _ -> y RStep y' -> case x of -- The last two cases make lastOf produce a Just as soon as any element -- is encountered, and possibly serve as a micro-optimisation; this - -- behaviour can be disabled by replacing them with _ -> mappend x y'. + -- 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 - ------------------------------------------------------------------------------- --- Folding with Reified Monoid ------------------------------------------------------------------------------- - -data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a } - -instance Reifies s (ReifiedMonoid a) => Monoid (M a s) where - mappend (M x) (M y) = reflectResult (\m -> M (reifiedMappend m x y)) - mempty = reflectResult (\m -> M (reifiedMempty m )) - -reflectResult :: Reifies s a => (a -> f s) -> f s -reflectResult f = let r = f (reflect r) in r - -newtype M a s = M a - -unM :: M a s -> proxy s -> a -unM (M a) _ = a - -reifyFold :: (a -> a -> a) -> a -> (forall s. Reifies s (ReifiedMonoid a) => t -> M a s) -> t -> a -reifyFold f z m xs = reify (ReifiedMonoid f z) (unM (m xs)) diff --git a/src/Control/Lens/Internal/Getter.hs b/src/Control/Lens/Internal/Getter.hs --- a/src/Control/Lens/Internal/Getter.hs +++ b/src/Control/Lens/Internal/Getter.hs @@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Getter --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -13,53 +13,23 @@ -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Getter - ( - -- * Internal Classes - Gettable - -- ** Getters - , coerce - , noEffect + ( noEffect , AlongsideLeft(..) , AlongsideRight(..) ) where -import Control.Applicative -import Control.Lens.Internal.Action +import Prelude () + +import Control.Lens.Internal.Prelude import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable -import Data.Foldable -import Data.Functor.Contravariant import Data.Semigroup.Foldable import Data.Semigroup.Traversable -import Data.Traversable -import Data.Void --- | This class is provided mostly for backwards compatibility with lens 3.8, --- but it can also shorten type signatures. -class (Contravariant f, Functor f) => Gettable f -instance (Contravariant f, Functor f) => Gettable f - -------------------------------------------------------------------------------- --- Gettables & Accessors -------------------------------------------------------------------------------- - --- | This Generalizes 'Const' so we can apply simple 'Applicative' --- transformations to it and so we can get nicer error messages. --- --- A 'Functor' you can 'coerce' ignores its argument, which it carries solely as a --- phantom type parameter. --- --- By the 'Functor' and 'Contravariant' laws, an instance of 'Gettable' will necessarily satisfy: --- --- @'id' = 'fmap' f = 'coerce' = 'contramap' g@ -coerce :: (Contravariant f, Functor f) => f a -> f b -coerce a = absurd <$> contramap absurd a -{-# INLINE coerce #-} - --- | The 'mempty' equivalent for a 'Gettable' 'Applicative' 'Functor'. +-- | The 'mempty' equivalent for a 'Contravariant' 'Applicative' 'Functor'. noEffect :: (Contravariant f, Applicative f) => f a -noEffect = coerce $ pure () +noEffect = phantom $ pure () {-# INLINE noEffect #-} newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) } @@ -103,12 +73,6 @@ bitraverse f g (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse g f) as {-# INLINE bitraverse #-} -instance Effective m r f => Effective m r (AlongsideLeft f b) where - effective = AlongsideLeft . effective - {-# INLINE effective #-} - ineffective = ineffective . getAlongsideLeft - {-# INLINE ineffective #-} - newtype AlongsideRight f a b = AlongsideRight { getAlongsideRight :: f (a, b) } deriving instance Show (f (a, b)) => Show (AlongsideRight f a b) @@ -149,9 +113,3 @@ instance Traversable f => Bitraversable (AlongsideRight f) where bitraverse f g (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse f g) as {-# INLINE bitraverse #-} - -instance Effective m r f => Effective m r (AlongsideRight f b) where - effective = AlongsideRight . effective - {-# INLINE effective #-} - ineffective = ineffective . getAlongsideRight - {-# INLINE ineffective #-} diff --git a/src/Control/Lens/Internal/Indexed.hs b/src/Control/Lens/Internal/Indexed.hs --- a/src/Control/Lens/Internal/Indexed.hs +++ b/src/Control/Lens/Internal/Indexed.hs @@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Indexed --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -31,28 +32,31 @@ -- * 64-bit Indexing , Indexing64(..) , indexing64 + -- * Converting to Folds + , withIndex + , asIndex ) where -import Control.Applicative +import Prelude () + import Control.Arrow as Arrow -import Control.Category +import qualified Control.Category as C import Control.Comonad +import Control.Lens.Internal.Prelude import Control.Lens.Internal.Instances () -import Control.Monad import Control.Monad.Fix import Data.Distributive import Data.Functor.Bind -import Data.Functor.Contravariant import Data.Int -import Data.Profunctor +import Data.Profunctor.Closed import Data.Profunctor.Rep -import Data.Traversable -import Prelude hiding ((.),id) -#ifndef SAFE -import Data.Profunctor.Unsafe -import Unsafe.Coerce -#endif +-- $setup +-- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens +-- >>> import Numeric.Lens +-- >>> import Data.Semigroup (Semigroup (..)) +-- ------------------------------------------------------------------------------ -- Conjoined ------------------------------------------------------------------------------ @@ -63,14 +67,14 @@ class ( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p) , Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Distributive (Rep p) - , ArrowLoop p, ArrowApply p, ArrowChoice p + , 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 . rep + 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. @@ -130,7 +134,7 @@ {-# INLINE (>>-) #-} instance Monad (Indexed i a) where - return b = Indexed $ \_ _ -> b + return = pure {-# INLINE return #-} Indexed f >>= k = Indexed $ \i a -> runIndexed (k (f i a)) i a {-# INLINE (>>=) #-} @@ -146,27 +150,37 @@ {-# INLINE lmap #-} rmap bc iab = Indexed $ \i -> bc . runIndexed iab i {-# INLINE rmap #-} -#ifndef SAFE - ( .# ) ibc _ = unsafeCoerce ibc - {-# INLINE ( .# ) #-} - ( #. ) _ = unsafeCoerce - {-# INLINE ( #. ) #-} -#endif + (.#) ibc _ = coerce ibc + {-# INLINE (.#) #-} + (#.) _ = coerce + {-# INLINE (#.) #-} -instance Corepresentable (Indexed i) where - type Corep (Indexed i) = (,) i - cotabulate = Indexed . curry - {-# INLINE cotabulate #-} - corep = uncurry . runIndexed - {-# INLINE corep #-} +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 #-} - rep = flip . runIndexed - {-# INLINE rep #-} +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' #-} @@ -175,7 +189,7 @@ second' = second {-# INLINE second' #-} -instance Category (Indexed i) where +instance C.Category (Indexed i) where id = Indexed (const id) {-# INLINE id #-} Indexed f . Indexed g = Indexed $ \i -> f i . g i @@ -251,6 +265,30 @@ (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. -- @@ -263,7 +301,7 @@ -- 'indexing' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int' s a -- @ -- --- @'indexing' :: 'Indexable' 'Int' p => 'Control.Lens.Type.LensLike' ('Indexing' f) s t a b -> 'Control.Lens.Type.Optical' p (->) f s t a b@ +-- @'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 #-} @@ -318,3 +356,28 @@ 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 #-} diff --git a/src/Control/Lens/Internal/Instances.hs b/src/Control/Lens/Internal/Instances.hs --- a/src/Control/Lens/Internal/Instances.hs +++ b/src/Control/Lens/Internal/Instances.hs @@ -1,62 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Instances --- Copyright : (C) 2012-2014 Edward Kmett +-- 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. +-- should be supplied by base. These have moved to @semigroupoids@ as of 4.2. ---------------------------------------------------------------------------- module Control.Lens.Internal.Instances () where -import Control.Applicative -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable - -#if !(MIN_VERSION_base(4,7,0)) -import Data.Monoid -import Data.Foldable -import Data.Traversable -#endif - -------------------------------------------------------------------------------- --- Orphan Instances -------------------------------------------------------------------------------- - -#if !(MIN_VERSION_base(4,7,0)) -instance Foldable ((,) b) where - foldMap f (_, a) = f a - -instance Traversable ((,) b) where - traverse f (b, a) = (,) b <$> f a - -instance Foldable (Either a) where - foldMap _ (Left _) = mempty - foldMap f (Right a) = f a - -instance Traversable (Either a) where - traverse _ (Left b) = pure (Left b) - traverse f (Right a) = Right <$> f a - -instance Foldable (Const m) where - foldMap _ _ = mempty - -instance Traversable (Const m) where - traverse _ (Const m) = pure $ Const m -#endif - -instance Foldable1 ((,) b) where - foldMap1 f (_, a) = f a - -instance Traversable1 ((,) b) where - traverse1 f (b, a) = (,) b <$> f a - +import Data.Orphans () +import Data.Traversable.Instances () diff --git a/src/Control/Lens/Internal/Iso.hs b/src/Control/Lens/Internal/Iso.hs --- a/src/Control/Lens/Internal/Iso.hs +++ b/src/Control/Lens/Internal/Iso.hs @@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Iso --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -18,19 +19,26 @@ ) where import Data.Profunctor -#ifndef SAFE import Data.Profunctor.Unsafe -import Unsafe.Coerce + +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) +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict #endif -import Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB -import Data.Text as StrictT -import Data.Text.Lazy as LazyT -import Data.Vector as Vector -import Data.Vector.Primitive as Prim -import Data.Vector.Storable as Storable -import Data.Vector.Unboxed as Unbox -import Data.Sequence as Seq +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) +import Foreign.Storable (Storable) ------------------------------------------------------------------------------ -- Isomorphism: Exchange @@ -51,12 +59,9 @@ {-# INLINE lmap #-} rmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE rmap #-} -#ifndef SAFE - ( #. ) _ = unsafeCoerce - {-# INLINE ( #. ) #-} - ( .# ) p _ = unsafeCoerce p - {-# INLINE ( .# ) #-} -#endif + (#.) _ = coerce + {-# INLINE (#.) #-} + (.#) p _ = coerce p ------------------------------------------------------------------------------ -- Reversible @@ -69,6 +74,9 @@ instance Reversing [a] where reversing = Prelude.reverse +instance Reversing (NonEmpty.NonEmpty a) where + reversing = NonEmpty.reverse + instance Reversing StrictB.ByteString where reversing = StrictB.reverse @@ -95,3 +103,8 @@ instance Storable a => Reversing (Storable.Vector a) where reversing = Storable.reverse + +#if MIN_VERSION_vector(0,13,2) +instance Reversing (VectorStrict.Vector a) where + reversing = VectorStrict.reverse +#endif diff --git a/src/Control/Lens/Internal/Level.hs b/src/Control/Lens/Internal/Level.hs --- a/src/Control/Lens/Internal/Level.hs +++ b/src/Control/Lens/Internal/Level.hs @@ -5,13 +5,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Level --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -29,16 +26,13 @@ , Flows(..) ) where -import Control.Applicative -import Control.Category -import Control.Comonad -import Data.Foldable +import Prelude () + +import Control.Lens.Internal.Prelude import Data.Functor.Apply -import Data.Int -import Data.Semigroup -import Data.Traversable -import Data.Word -import Prelude hiding ((.),id) +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Levels @@ -95,6 +89,27 @@ 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 ------------------------------------------------------------------------------ @@ -112,10 +127,12 @@ 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 diff --git a/src/Control/Lens/Internal/List.hs b/src/Control/Lens/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/List.hs @@ -0,0 +1,73 @@ +{-# 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 #-} diff --git a/src/Control/Lens/Internal/Magma.hs b/src/Control/Lens/Internal/Magma.hs --- a/src/Control/Lens/Internal/Magma.hs +++ b/src/Control/Lens/Internal/Magma.hs @@ -1,22 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -38,20 +33,18 @@ , runTakingWhile ) where -import Control.Applicative -import Control.Category +import Prelude () + import Control.Comonad import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed -import Data.Foldable +import Control.Lens.Internal.Prelude import Data.Functor.Apply -import Data.Functor.Contravariant -import Data.Monoid -import Data.Profunctor.Rep -import Data.Profunctor.Unsafe -import Data.Traversable -import Prelude hiding ((.),id) +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Kind +import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Magma @@ -65,10 +58,8 @@ MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a Magma :: i -> a -> Magma i b b a -#if __GLASGOW_HASKELL__ >= 707 -- note the 3rd argument infers as phantom, but that would be unsound type role Magma representational nominal nominal nominal -#endif instance Functor (Magma i t b) where fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y) @@ -88,6 +79,27 @@ 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 @@ -198,7 +210,7 @@ instance Bizarre (Indexed Int) Mafic where bazaar (pafb :: Indexed Int a (f b)) (Mafic _ k) = go (k 0) where - go :: Applicative f => Magma Int t b a -> f t + go :: 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 @@ -219,13 +231,11 @@ -- -- 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 :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) -#if __GLASGOW_HASKELL__ >= 707 +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 -#endif -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. -runTakingWhile :: Corepresentable p => TakingWhile p f a b t -> Magma () t b (Corep p a) +runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a) runTakingWhile (TakingWhile _ _ k) = k True instance Functor (TakingWhile p f a b) where @@ -246,13 +256,14 @@ instance Corepresentable p => Bizarre p (TakingWhile p g) where bazaar (pafb :: p a (f b)) ~(TakingWhile _ _ k) = go (k True) where - go :: Applicative f => Magma () t b (Corep p a) -> f t + go :: Magma () t b (Corep p a) -> f t go (MagmaAp x y) = go x <*> go y go (MagmaFmap f x) = f <$> go x go (MagmaPure x) = pure x - go (Magma _ wa) = corep pafb wa + 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 #-} diff --git a/src/Control/Lens/Internal/Prelude.hs b/src/Control/Lens/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/Prelude.hs @@ -0,0 +1,120 @@ +{-# 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 diff --git a/src/Control/Lens/Internal/Prism.hs b/src/Control/Lens/Internal/Prism.hs --- a/src/Control/Lens/Internal/Prism.hs +++ b/src/Control/Lens/Internal/Prism.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE CPP #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Prism --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -17,12 +14,10 @@ , Market' ) where -import Data.Profunctor -#ifndef SAFE -import Data.Profunctor.Unsafe -import Unsafe.Coerce -#endif +import Prelude () +import Control.Lens.Internal.Prelude + ------------------------------------------------------------------------------ -- Prism: Market ------------------------------------------------------------------------------ @@ -46,12 +41,10 @@ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE rmap #-} -#ifndef SAFE - ( #. ) _ = unsafeCoerce - {-# INLINE ( #. ) #-} - ( .# ) p _ = unsafeCoerce p - {-# INLINE ( .# ) #-} -#endif + (#.) _ = coerce + {-# INLINE (#.) #-} + (.#) p _ = coerce p + {-# INLINE (.#) #-} instance Choice (Market a b) where left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of diff --git a/src/Control/Lens/Internal/PrismTH.hs b/src/Control/Lens/Internal/PrismTH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/PrismTH.hs @@ -0,0 +1,539 @@ +{-# 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 diff --git a/src/Control/Lens/Internal/Profunctor.hs b/src/Control/Lens/Internal/Profunctor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/Profunctor.hs @@ -0,0 +1,17 @@ +module 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 diff --git a/src/Control/Lens/Internal/Reflection.hs b/src/Control/Lens/Internal/Reflection.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/Reflection.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-cse #-} -{-# OPTIONS_GHC -fno-full-laziness #-} -{-# OPTIONS_GHC -fno-float-in #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} ----------------------------------------------------------------------------- --- | --- Module : Control.Lens.Internal.Reflection --- Copyright : 2009-2014 Edward Kmett, --- 2012 Elliott Hird, --- 2004 Oleg Kiselyov and Chung-chieh Shan --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- Reifies arbitrary terms at the type level. Based on the Functional --- Pearl: Implicit Configurations paper by Oleg Kiselyov and --- Chung-chieh Shan. --- --- --- --- The approach from the paper was modified to work with Data.Proxy --- and streamline the API by Edward Kmett and Elliott Hird. --- --- Usage comes down to two combinators, 'reify' and 'reflect'. --- --- >>> reify 6 (\p -> reflect p + reflect p) --- 12 --- --- The argument passed along by reify is just a @data 'Proxy' t = --- Proxy@, so all of the information needed to reconstruct your value --- has been moved to the type level. This enables it to be used when --- constructing instances (see @examples/Monoid.hs@). --- --- This version is based on the \"slow\" path from the @reflection@ package, --- but modified to work with the same 'Reifies' class as is provided by the \"fast\" --- path, and to make sure the parameter is 'Typeable'. --- --- This is necessary to work around the changes to @Data.Typeable@ in GHC HEAD. -------------------------------------------------------------------------------- - -module Control.Lens.Internal.Reflection - ( - Reifies(..) - , reifyTypeable - ) where - -import Foreign.Ptr -import Foreign.StablePtr -import System.IO.Unsafe -import Control.Applicative -import Data.Proxy -import Data.Bits -import Data.Word -import Data.Typeable -import Data.Reflection - -{-# ANN module "HLint: ignore Avoid lambda" #-} - -class Typeable s => B s where - reflectByte :: proxy s -> IntPtr - -#define BYTES(GO) \ - GO(T0,0) GO(T1,1) GO(T2,2) GO(T3,3) GO(T4,4) GO(T5,5) GO(T6,6) GO(T7,7) GO(T8,8) GO(T9,9) GO(T10,10) GO(T11,11) \ - GO(T12,12) GO(T13,13) GO(T14,14) GO(T15,15) GO(T16,16) GO(T17,17) GO(T18,18) GO(T19,19) GO(T20,20) GO(T21,21) GO(T22,22) \ - GO(T23,23) GO(T24,24) GO(T25,25) GO(T26,26) GO(T27,27) GO(T28,28) GO(T29,29) GO(T30,30) GO(T31,31) GO(T32,32) GO(T33,33) \ - GO(T34,34) GO(T35,35) GO(T36,36) GO(T37,37) GO(T38,38) GO(T39,39) GO(T40,40) GO(T41,41) GO(T42,42) GO(T43,43) GO(T44,44) \ - GO(T45,45) GO(T46,46) GO(T47,47) GO(T48,48) GO(T49,49) GO(T50,50) GO(T51,51) GO(T52,52) GO(T53,53) GO(T54,54) GO(T55,55) \ - GO(T56,56) GO(T57,57) GO(T58,58) GO(T59,59) GO(T60,60) GO(T61,61) GO(T62,62) GO(T63,63) GO(T64,64) GO(T65,65) GO(T66,66) \ - GO(T67,67) GO(T68,68) GO(T69,69) GO(T70,70) GO(T71,71) GO(T72,72) GO(T73,73) GO(T74,74) GO(T75,75) GO(T76,76) GO(T77,77) \ - GO(T78,78) GO(T79,79) GO(T80,80) GO(T81,81) GO(T82,82) GO(T83,83) GO(T84,84) GO(T85,85) GO(T86,86) GO(T87,87) GO(T88,88) \ - GO(T89,89) GO(T90,90) GO(T91,91) GO(T92,92) GO(T93,93) GO(T94,94) GO(T95,95) GO(T96,96) GO(T97,97) GO(T98,98) GO(T99,99) \ - GO(T100,100) GO(T101,101) GO(T102,102) GO(T103,103) GO(T104,104) GO(T105,105) GO(T106,106) GO(T107,107) GO(T108,108) \ - GO(T109,109) GO(T110,110) GO(T111,111) GO(T112,112) GO(T113,113) GO(T114,114) GO(T115,115) GO(T116,116) GO(T117,117) \ - GO(T118,118) GO(T119,119) GO(T120,120) GO(T121,121) GO(T122,122) GO(T123,123) GO(T124,124) GO(T125,125) GO(T126,126) \ - GO(T127,127) GO(T128,128) GO(T129,129) GO(T130,130) GO(T131,131) GO(T132,132) GO(T133,133) GO(T134,134) GO(T135,135) \ - GO(T136,136) GO(T137,137) GO(T138,138) GO(T139,139) GO(T140,140) GO(T141,141) GO(T142,142) GO(T143,143) GO(T144,144) \ - GO(T145,145) GO(T146,146) GO(T147,147) GO(T148,148) GO(T149,149) GO(T150,150) GO(T151,151) GO(T152,152) GO(T153,153) \ - GO(T154,154) GO(T155,155) GO(T156,156) GO(T157,157) GO(T158,158) GO(T159,159) GO(T160,160) GO(T161,161) GO(T162,162) \ - GO(T163,163) GO(T164,164) GO(T165,165) GO(T166,166) GO(T167,167) GO(T168,168) GO(T169,169) GO(T170,170) GO(T171,171) \ - GO(T172,172) GO(T173,173) GO(T174,174) GO(T175,175) GO(T176,176) GO(T177,177) GO(T178,178) GO(T179,179) GO(T180,180) \ - GO(T181,181) GO(T182,182) GO(T183,183) GO(T184,184) GO(T185,185) GO(T186,186) GO(T187,187) GO(T188,188) GO(T189,189) \ - GO(T190,190) GO(T191,191) GO(T192,192) GO(T193,193) GO(T194,194) GO(T195,195) GO(T196,196) GO(T197,197) GO(T198,198) \ - GO(T199,199) GO(T200,200) GO(T201,201) GO(T202,202) GO(T203,203) GO(T204,204) GO(T205,205) GO(T206,206) GO(T207,207) \ - GO(T208,208) GO(T209,209) GO(T210,210) GO(T211,211) GO(T212,212) GO(T213,213) GO(T214,214) GO(T215,215) GO(T216,216) \ - GO(T217,217) GO(T218,218) GO(T219,219) GO(T220,220) GO(T221,221) GO(T222,222) GO(T223,223) GO(T224,224) GO(T225,225) \ - GO(T226,226) GO(T227,227) GO(T228,228) GO(T229,229) GO(T230,230) GO(T231,231) GO(T232,232) GO(T233,233) GO(T234,234) \ - GO(T235,235) GO(T236,236) GO(T237,237) GO(T238,238) GO(T239,239) GO(T240,240) GO(T241,241) GO(T242,242) GO(T243,243) \ - GO(T244,244) GO(T245,245) GO(T246,246) GO(T247,247) GO(T248,248) GO(T249,249) GO(T250,250) GO(T251,251) GO(T252,252) \ - GO(T253,253) GO(T254,254) GO(T255,255) - -#define GO(Tn,n) \ - newtype Tn = Tn Tn deriving Typeable; \ - instance B Tn where { \ - reflectByte _ = n \ - }; -BYTES(GO) -#undef GO - -impossible :: a -impossible = error "Data.Reflection.reifyByte: impossible" - -reifyByte :: Word8 -> (forall s. B s => Proxy s -> r) -> r -reifyByte w k = case w of { -#define GO(Tn,n) n -> k (Proxy :: Proxy Tn); -BYTES(GO) -#undef GO -_ -> impossible -} - -newtype W b0 b1 b2 b3 = W (W b0 b1 b2 b3) deriving Typeable -newtype Stable w0 w1 a = Stable (Stable w0 w1 a) deriving Typeable - -stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7 - -> Proxy (Stable (W b0 b1 b2 b3) (W b4 b5 b6 b7) a) -stable _ _ _ _ _ _ _ _ = Proxy -{-# INLINE stable #-} - -stablePtrToIntPtr :: StablePtr a -> IntPtr -stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr -{-# INLINE stablePtrToIntPtr #-} - -intPtrToStablePtr :: IntPtr -> StablePtr a -intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr -{-# INLINE intPtrToStablePtr #-} - -byte0 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b0 -byte0 _ = Proxy - -byte1 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b1 -byte1 _ = Proxy - -byte2 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b2 -byte2 _ = Proxy - -byte3 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b3 -byte3 _ = Proxy - -byte4 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b4 -byte4 _ = Proxy - -byte5 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b5 -byte5 _ = Proxy - -byte6 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b6 -byte6 _ = Proxy - -byte7 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b7 -byte7 _ = Proxy - -argument :: (p s -> r) -> Proxy s -argument _ = Proxy - -instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7, w0 ~ W b0 b1 b2 b3, w1 ~ W b4 b5 b6 b7) - => Reifies (Stable w0 w1 a) a where - reflect = r where - r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p - s = argument r - p = intPtrToStablePtr $ - reflectByte (byte0 s) .|. - (reflectByte (byte1 s) `shiftL` 8) .|. - (reflectByte (byte2 s) `shiftL` 16) .|. - (reflectByte (byte3 s) `shiftL` 24) .|. - (reflectByte (byte4 s) `shiftL` 32) .|. - (reflectByte (byte5 s) `shiftL` 40) .|. - (reflectByte (byte6 s) `shiftL` 48) .|. - (reflectByte (byte7 s) `shiftL` 56) - {-# NOINLINE reflect #-} - --- This had to be moved to the top level, due to an apparent bug in --- the ghc inliner introduced in ghc 7.0.x -reflectBefore :: Reifies s a => (Proxy s -> b) -> proxy s -> b -reflectBefore f = const $! f Proxy -{-# NOINLINE reflectBefore #-} - --- | Reify a value at the type level in a 'Typeable'-compatible fashion, to be recovered with 'reflect'. -reifyTypeable :: Typeable a => a -> (forall s. (Typeable s, Reifies s a) => Proxy s -> r) -> r -reifyTypeable a k = unsafeDupablePerformIO $ do - p <- newStablePtr a - let n = stablePtrToIntPtr p - reifyByte (fromIntegral n) (\s0 -> - reifyByte (fromIntegral (n `shiftR` 8)) (\s1 -> - reifyByte (fromIntegral (n `shiftR` 16)) (\s2 -> - reifyByte (fromIntegral (n `shiftR` 24)) (\s3 -> - reifyByte (fromIntegral (n `shiftR` 32)) (\s4 -> - reifyByte (fromIntegral (n `shiftR` 40)) (\s5 -> - reifyByte (fromIntegral (n `shiftR` 48)) (\s6 -> - reifyByte (fromIntegral (n `shiftR` 56)) (\s7 -> - reflectBefore (fmap return k) $ - stable s0 s1 s2 s3 s4 s5 s6 s7)))))))) diff --git a/src/Control/Lens/Internal/Review.hs b/src/Control/Lens/Internal/Review.hs --- a/src/Control/Lens/Internal/Review.hs +++ b/src/Control/Lens/Internal/Review.hs @@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Review --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional diff --git a/src/Control/Lens/Internal/Setter.hs b/src/Control/Lens/Internal/Setter.hs --- a/src/Control/Lens/Internal/Setter.hs +++ b/src/Control/Lens/Internal/Setter.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} -#ifdef TRUSTWORTHY + {-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Setter --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -18,14 +18,11 @@ Settable(..) ) where -import Control.Applicative +import Prelude () + import Control.Applicative.Backwards +import Control.Lens.Internal.Prelude import Data.Distributive -import Data.Functor.Compose -import Data.Functor.Identity -import Data.Profunctor -import Data.Profunctor.Unsafe -import Data.Traversable ----------------------------------------------------------------------------- -- Settable diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs --- a/src/Control/Lens/Internal/TH.hs +++ b/src/Control/Lens/Internal/TH.hs @@ -1,48 +1,268 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} #ifdef TRUSTWORTHY +# if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE Safe #-} +# else {-# LANGUAGE Trustworthy #-} +# endif #endif -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) -#endif +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.TH --- Copyright : (C) 2013-2014 Edward Kmett, 2013 Eric Mertens +-- 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 where +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 - --- | Compatibility shim for recent changes to template haskell's 'tySynInstD' -tySynInstD' :: Name -> [TypeQ] -> TypeQ -> DecQ -#if MIN_VERSION_template_haskell(2,9,0) -tySynInstD' fam ts r = tySynInstD fam (tySynEqn ts r) -#else -tySynInstD' = tySynInstD -#endif +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] diff --git a/src/Control/Lens/Internal/TupleIxedTH.hs b/src/Control/Lens/Internal/TupleIxedTH.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/TupleIxedTH.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.Internal.TupleIxedTH --- Copyright : (C) 2014 Edward Kmett --- (C) 2012-13 Eric Mertens --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Control.Lens.Internal.TupleIxedTH - ( makeAllTupleIxed - ) where - -import Control.Applicative -import Data.Traversable (traverse) -import Language.Haskell.TH - -import Control.Lens.Internal.TH - --- This module needs to be used by Control.Lens.At which defines these names -indexN, ixValueN, ixedN, ixN :: Name -indexN = mkName "Index" -ixValueN = mkName "IxValue" -ixedN = mkName "Ixed" -ixN = mkName "ix" - --- While GHC supports tuples up to 62, it can't cope with the resulting --- large definitions. 9-tuples should be enough for anyone. - --- This generates all of the Ixed instances for tuples up to 9. -makeAllTupleIxed :: DecsQ -makeAllTupleIxed = fmap concat (traverse makeTupleIxed [2..9]) - --- type instance Index (a,..) = Int --- type instance IxValue (a,..) = a --- instance (a~b,a~c...) => Ixed (a,b,c..) where --- ix i f (a,b,c..) = fmap (\x -> (a,b,c...x..)) (f z) --- ix _ f x = pure x -makeTupleIxed :: Int -> DecsQ -makeTupleIxed n = sequence [tupleIndex n, tupleIxValue n, tupleIxed n] - --- type instance Index (a,..) = Int -tupleIndex :: Int -> DecQ -tupleIndex n = tySynInstD' indexN [fullTupleT n] [t|Int|] - --- type instance IxValue (a,..) = a -tupleIxValue :: Int -> DecQ -tupleIxValue n = tySynInstD' ixValueN [fullTupleT n] (head tupleVarTypes) - --- (a,..) -fullTupleT :: Int -> TypeQ -fullTupleT n = toTupleT (take n tupleVarTypes) - --- instance (a~b,a~c...) => Ixed (a,b,c..) where --- ix i f (a,b,c..) = fmap (\x -> (a,b,c...x..)) (f z) --- ix _ f x = pure x -tupleIxed :: Int -> DecQ -tupleIxed n = instanceD (cxt eqs) (conT ixedN `appT` fullTupleT n) [funD ixN clauses] - where - ty0:tyN = take n tupleVarTypes -#if MIN_VERSION_template_haskell(2,10,0) - eqs = [AppT . AppT EqualityT <$> ty0 <*> ty | ty <- tyN] -#else - eqs = [ty0 `equalP` ty | ty <- tyN] -#endif - clauses = map nClause [0..n-1] ++ [otherClause] - - -- ix i f (a,..) = fmap (\x->(a,..x..)) (f z) - nClause i = do - let iP = litP (integerL (fromIntegral i)) - f <- newName "f" - let fP = varP f - fE = varE f - xs <- mapM newName (take n nameSource) - let xsP = map varP xs - xsE = map varE xs - xE = varE (xs !! i) - clause [iP, fP, toTupleP xsP] - (normalB [| fmap (\x -> $(toTupleE (replaceAt i [|x|] xsE))) ($fE $xE) |]) - [] - - -- ix _ _ x = pure x - otherClause = do - x <- newName "x" - clause [wildP, wildP, varP x] (normalB [|pure $(varE x)|]) [] - -tupleVarTypes :: [TypeQ] -tupleVarTypes = map (varT . mkName) nameSource - --- [a,b,c,d...a1,b1,b2...a2,b2,c3...] -nameSource :: [String] -nameSource = [ a:n | n <- "" : map show [1 :: Int ..] - , a <- ['a'..'z'] - ] - --- While this could be easily implemented as 'set . ix' --- this local definition removes any circular dependency --- issues. -replaceAt :: Int -> a -> [a] -> [a] -replaceAt 0 x (_:ys) = x : ys -replaceAt i x (y:ys) = y : replaceAt (i-1) x ys -replaceAt _ _ [] = error "replaceAt: index too large" diff --git a/src/Control/Lens/Internal/Zoom.hs b/src/Control/Lens/Internal/Zoom.hs --- a/src/Control/Lens/Internal/Zoom.hs +++ b/src/Control/Lens/Internal/Zoom.hs @@ -1,16 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Zoom --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -20,55 +18,24 @@ module Control.Lens.Internal.Zoom ( -- * Zoom - Zoomed - , Focusing(..) + Focusing(..) , FocusingWith(..) , FocusingPlus(..) , FocusingOn(..) , FocusingMay(..), May(..) , FocusingErr(..), Err(..) + , FocusingFree(..), Freed(..) -- * Magnify - , Magnified + , Effect(..) , EffectRWS(..) ) where -import Control.Applicative -import Control.Category -import Control.Comonad -import Control.Lens.Internal.Action -import Control.Monad.Reader as Reader -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Error -import Control.Monad.Trans.List -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Maybe -import Data.Functor.Bind -import Data.Functor.Contravariant -import Data.Semigroup -import Prelude hiding ((.),id) - ------------------------------------------------------------------------------- --- Zoomed ------------------------------------------------------------------------------- +import Prelude () --- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. -type family Zoomed (m :: * -> *) :: * -> * -> * -type instance Zoomed (Strict.StateT s z) = Focusing z -type instance Zoomed (Lazy.StateT s z) = Focusing z -type instance Zoomed (ReaderT e m) = Zoomed m -type instance Zoomed (IdentityT m) = Zoomed m -type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z -type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z -type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) -type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) -type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) -type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) -type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) +import Control.Lens.Internal.Prelude +import Control.Monad +import Control.Monad.Trans.Free +import Data.Functor.Bind ------------------------------------------------------------------------------ -- Focusing @@ -186,10 +153,12 @@ 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 @@ -228,10 +197,12 @@ 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 @@ -255,16 +226,88 @@ {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ --- Magnified +-- Freed ------------------------------------------------------------------------------ --- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. -type family Magnified (m :: * -> *) :: * -> * -> * -type instance Magnified (ReaderT b m) = Effect m -type instance Magnified ((->)b) = 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 +-- | 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 diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs --- a/src/Control/Lens/Iso.hs +++ b/src/Control/Lens/Iso.hs @@ -1,22 +1,27 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -#ifdef TRUSTWORTHY +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-} -#endif -#ifndef MIN_VERSION_bytestring -#define MIN_VERSION_bytestring(x,y,z) 1 +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE PolyKinds #-} +#else +{-# LANGUAGE TypeInType #-} #endif + +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Iso --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional --- Portability : Rank2Types +-- Portability : Rank2Types, TypeFamilies, FunctionalDependencies -- ---------------------------------------------------------------------------- module Control.Lens.Iso @@ -33,6 +38,8 @@ -- * Working with isomorphisms , au , auf + , xplat + , xplatf , under , mapping -- ** Common Isomorphisms @@ -42,11 +49,16 @@ , enum , curried, uncurried , flipped - , Swapped(..) - , Strict(..) - , lazy - , Reversing(..), reversed + , swapped + , pattern Swapped + , strict, lazy + , pattern Strict + , pattern Lazy + , Reversing(..) + , reversed + , pattern Reversed , involuted + , pattern List -- ** Uncommon Isomorphisms , magma , imagma @@ -60,9 +72,14 @@ , 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 @@ -71,31 +88,24 @@ import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Type -import Control.Monad.State.Lazy as Lazy -import Control.Monad.State.Strict as Strict -import Control.Monad.Writer.Lazy as Lazy -import Control.Monad.Writer.Strict as Strict -import Control.Monad.RWS.Lazy as Lazy -import Control.Monad.RWS.Strict as Strict -import Data.ByteString as StrictB hiding (reverse) -import Data.ByteString.Lazy as LazyB hiding (reverse) -import Data.Functor.Contravariant + +import Data.Bifunctor +import Data.Bifunctor.Swap (Swap (..)) import Data.Functor.Identity -import Data.Text as StrictT hiding (reverse) -import Data.Text.Lazy as LazyT hiding (reverse) -import Data.Tuple (swap) +import Data.Strict.Classes (Strict (..)) import Data.Maybe import Data.Profunctor import Data.Profunctor.Unsafe -#ifdef HLINT -{-# ANN module "HLint: ignore Use on" #-} -#endif +import Data.Coerce +import qualified GHC.Exts as Exts +import GHC.Exts (TYPE) + -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens --- >>> import Data.Map as Map +-- >>> import qualified Data.Map as Map -- >>> import Data.Foldable -- >>> import Data.Monoid @@ -132,12 +142,13 @@ -- 'from' ('from' l) ≡ l -- @ from :: AnIso s t a b -> Iso b a t s -from l = withIso l $ \ sa bt -> iso bt sa +from l = withIso l $ \sa bt -> iso bt sa {-# INLINE from #-} -- | Extract the two functions, one from @s -> a@ and -- one from @b -> t@ that characterize an 'Iso'. -withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r +withIso :: 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 #-} @@ -149,7 +160,7 @@ -- -- See 'Control.Lens.Lens.cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this. cloneIso :: AnIso s t a b -> Iso s t a b -cloneIso k = withIso k iso +cloneIso k = withIso k $ \sa bt -> iso sa bt {-# INLINE cloneIso #-} ----------------------------------------------------------------------------- @@ -160,10 +171,20 @@ -- -- This version is generalized to accept any 'Iso', not just a @newtype@. -- --- >>> au (_Unwrapping Sum) foldMap [1,2,3,4] +-- >>> au (_Wrapping Sum) foldMap [1,2,3,4] -- 10 -au :: AnIso s t a b -> ((s -> a) -> e -> b) -> e -> t -au k = withIso k $ \ sa bt f e -> bt (f sa e) +-- +-- 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. @@ -172,15 +193,41 @@ -- -- 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. +-- is 'au' with an extra function argument: -- --- >>> auf (_Unwrapping Sum) (foldMapOf both) Prelude.length ("hello","world") --- 10 -auf :: Profunctor p => AnIso s t a b -> (p r a -> e -> b) -> p r s -> e -> t -auf k = withIso k $ \ sa bt f g e -> bt (f (rmap sa g) e) +-- @ +-- '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. -- -- @ @@ -253,10 +300,18 @@ -- and when have deleting the last entry from the nested 'Data.Map.Map' mean that we -- should delete its entry from the surrounding one: -- --- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing +-- >>> 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 = non' . only +non a = non' $ only a {-# INLINE non #-} -- | @'non'' p@ generalizes @'non' (p # ())@ to take any unit 'Prism' @@ -266,7 +321,7 @@ -- >>> Map.singleton "hello" Map.empty & at "hello" . non' _Empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- --- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing +-- >>> 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 @@ -282,7 +337,7 @@ -- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- --- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing +-- >>> 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 @@ -329,54 +384,45 @@ flipped = iso flip flip {-# INLINE flipped #-} --- | This class provides for symmetric bifunctors. -class Bifunctor p => Swapped p where - -- | - -- @ - -- 'swapped' '.' 'swapped' ≡ 'id' - -- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f - -- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g - -- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f - -- @ - -- - -- >>> (1,2)^.swapped - -- (2,1) - swapped :: Iso (p a b) (p c d) (p b a) (p d c) - -instance Swapped (,) where - swapped = iso swap swap - -instance Swapped Either where - swapped = iso (either Right Left) (either Right Left) - --- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure, --- such as 'StrictT.Text' or 'StrictB.ByteString'. -class Strict lazy strict | lazy -> strict, strict -> lazy where - strict :: Iso' lazy strict +-- | +-- @ +-- '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 #-} -instance Strict LazyB.ByteString StrictB.ByteString where -#if MIN_VERSION_bytestring(0,10,0) - strict = iso LazyB.toStrict LazyB.fromStrict -#else - strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return) -#endif - {-# INLINE strict #-} +-- | 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 #-} -instance Strict LazyT.Text StrictT.Text where - strict = iso LazyT.toStrict LazyT.fromStrict - {-# INLINE strict #-} +pattern Strict :: Strict s t => t -> s +pattern Strict a <- (view strict -> a) where + Strict a = review strict a -instance Strict (Lazy.StateT s m a) (Strict.StateT s m a) where - strict = iso (Strict.StateT . Lazy.runStateT) (Lazy.StateT . Strict.runStateT) - {-# INLINE strict #-} +pattern Lazy :: Strict t s => t -> s +pattern Lazy a <- (view lazy -> a) where + Lazy a = review lazy a -instance Strict (Lazy.WriterT w m a) (Strict.WriterT w m a) where - strict = iso (Strict.WriterT . Lazy.runWriterT) (Lazy.WriterT . Strict.runWriterT) - {-# INLINE strict #-} +pattern Swapped :: Swap p => p b a -> p a b +pattern Swapped a <- (view swapped -> a) where + Swapped a = review swapped a -instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where - strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST) - {-# INLINE strict #-} +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. @@ -385,10 +431,9 @@ -- 'lazy' = 'from' 'strict' -- @ -- --- See for an example --- use. lazy :: Strict lazy strict => Iso' strict lazy -lazy = from strict +lazy = iso toLazy toStrict +{-# INLINE lazy #-} -- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal. -- @@ -415,6 +460,10 @@ 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 ------------------------------------------------------------------------------ @@ -489,10 +538,41 @@ -- | Lift two 'Iso's into both arguments of a 'Bifunctor'. -- -- @ --- bimapping :: 'Profunctor' 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 :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p s s') (p a a') +-- 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 #-} diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs --- a/src/Control/Lens/Lens.hs +++ b/src/Control/Lens/Lens.hs @@ -5,17 +5,20 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE PolyKinds #-} +#else +{-# LANGUAGE TypeInType #-} #endif + +#include "lens-common.h" + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -24,11 +27,11 @@ -- A @'Lens' s t a b@ is a purely functional reference. -- -- While a 'Control.Lens.Traversal.Traversal' could be used for --- 'Control.Lens.Getter.Getting' like a valid 'Control.Lens.Fold.Fold', --- it wasn't a valid 'Control.Lens.Getter.Getter' as 'Applicative' wasn't a superclass of --- 'Control.Lens.Getter.Gettable'. +-- '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 the superclass of both. +-- 'Functor', however, is a constraint on both. -- -- @ -- type 'Lens' s t a b = forall f. 'Functor' f => (a -> f b) -> s -> f t @@ -38,13 +41,13 @@ -- -- Every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a -- 'Control.Lens.Fold.Fold' that doesn't use the 'Applicative' or --- 'Control.Lens.Getter.Gettable'. +-- '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 'Functor' is a superclass of 'Control.Lens.Getter.Gettable'. +-- '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 @@ -67,7 +70,7 @@ , AnIndexedLens, AnIndexedLens' -- * Combinators - , lens, ilens, iplens + , lens, ilens, iplens, withLens , (%%~), (%%=) , (%%@~), (%%@=) , (<%@~), (<%@=) @@ -84,18 +87,18 @@ -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (~) - , (<<%~), (<<.~), (<<+~), (<<-~), (<<*~) + , (<||~), (<&&~), (<<>~), (<<>:~) + , (<<%~), (<<.~), (<~) + , (<<||~), (<<&&~), (<<<>~), (<<<>:~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=) - , (<<%=), (<<.=), (<<+=), (<<-=), (<<*=) + , (<||=), (<&&=), (<<>=), (<<>:=) + , (<<%=), (<<.=), (<=) + , (<<||=), (<<&&=), (<<<>=), (<<<>:=) , (<<~) -- * Cloning Lenses @@ -109,41 +112,48 @@ -- * ALens Combinators , storing , (^#) - , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~) - , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=) + , (#~), (#%~), (#%%~), (<#~), (<#%~) + , (#=), (#%=), (#%%=), (<#=), (<#%=) -- * Common Lenses , devoid , united + , head1, last1 -- * Context , Context(..) , Context' , locus + + -- * Lens fusion + , fusing ) where -import Control.Applicative +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.Monoid -import Data.Profunctor -import Data.Profunctor.Rep -import Data.Profunctor.Unsafe -import Data.Void - -#ifdef HLINT -{-# ANN module "HLint: ignore Use ***" #-} -#endif +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 @@ -153,10 +163,12 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^# -infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <%~, <<%~, <<.~, <#~, #~, #%~, <#%~, #%%~ -infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <%=, <<%=, <<.=, <#=, #=, #%=, <#%=, #%%= +infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <<>:~, <%~, <<%~, <<.~, <~, <<<>:~ +infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <<>:=, <%=, <<%=, <<.=, <=, <<<>:= infixr 2 <<~ -infixl 1 &, <&>, ??, &~ +infixl 1 ??, &~ ------------------------------------------------------------------------------- -- Lenses @@ -208,10 +220,16 @@ 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) <$> corep pafb (sa <$> ws) +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 @@ -246,6 +264,9 @@ -- 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: -- -- @ @@ -270,7 +291,7 @@ -- ('%%~') :: 'Lens' s t a b -> (a -> (r, b)) -> s -> (r, t) -- ('%%~') :: 'Monoid' m => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> (m, b)) -> s -> (m, t) -- @ -(%%~) :: Optical p q f s t a b -> p a (f b) -> q s (f t) +(%%~) :: LensLike f s t a b -> (a -> f b) -> s -> f t (%%~) = id {-# INLINE (%%~) #-} @@ -295,55 +316,26 @@ -- ('%%=') :: ('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 -#if MIN_VERSION_mtl(2,1,1) l %%= f = State.state (l f) -#else -l %%= f = do - (r, s) <- State.gets (l f) - State.put s - return r -#endif {-# INLINE (%%=) #-} ------------------------------------------------------------------------------- -- General Purpose Combinators ------------------------------------------------------------------------------- --- | Passes the result of the left side to the function on the right side (forward pipe operator). --- --- This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed --- for inference. Here it is supplied for notational convenience and given a precedence that allows it --- to be nested inside uses of ('$'). --- --- >>> a & f --- f a --- --- >>> "hello" & length & succ --- 6 --- --- This combinator is commonly used when applying multiple 'Lens' operations in sequence. +-- | This is convenient to 'flip' argument order of composite functions defined as: -- --- >>> ("hello","world") & _1.element 0 .~ 'j' & _1.element 4 .~ 'y' --- ("jelly","world") +-- @ +-- fab ?? a = fmap ($ a) fab +-- @ -- --- This reads somewhat similar to: +-- For the 'Functor' instance @f = ((->) r)@ you can reason about this function as if the definition was @('??') ≡ 'flip'@: -- --- >>> flip execState ("hello","world") $ do _1.element 0 .= 'j'; _1.element 4 .= 'y' --- ("jelly","world") -(&) :: a -> (a -> b) -> b -a & f = f a -{-# INLINE (&) #-} - --- | Infix flipped 'fmap'. +-- >>> (h ?? x) a +-- h a x -- --- @ --- ('<&>') = 'flip' 'fmap' --- @ -(<&>) :: Functor f => f a -> (a -> b) -> f b -as <&> f = f <$> as -{-# INLINE (<&>) #-} - --- | This is convenient to 'flip' argument order of composite functions. +-- >>> execState ?? [] $ modify (1:) +-- [1] -- -- >>> over _2 ?? ("hello","world") $ length -- ("hello",5) @@ -364,10 +356,16 @@ -- '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 (corep es e) - o ea = cotabulate $ \ e -> ipeek (corep ea e) $ l sell (corep es e) + i = cotabulate $ \ e -> ipos $ l sell (cosieve es e) + o ea = cotabulate $ \ e -> ipeek (cosieve ea e) $ l sell (cosieve es e) {-# INLINE inside #-} {- @@ -424,7 +422,7 @@ -- 'chosen' f ('Right' a) = 'Right' '<$>' f a -- @ chosen :: IndexPreservingLens (Either a a) (Either b b) a b -chosen pafb = cotabulate $ \weaa -> corep (either id id `lmap` pafb) weaa <&> \b -> case extract weaa of +chosen pafb = cotabulate $ \weaa -> cosieve (either id id `lmap` pafb) weaa <&> \b -> case extract weaa of Left _ -> Left b Right _ -> Right b {-# INLINE chosen #-} @@ -440,7 +438,7 @@ -- -- @ -- 'alongside' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b') --- 'alongside' :: 'Getter' s t a b -> 'Getter' s' t' a' b' -> 'Getter' (s,s') (t,t') (a,a') (b,b') +-- 'alongside' :: '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' @@ -489,7 +487,7 @@ -- | Clone a 'Lens' as an 'IndexedPreservingLens' that just passes through whatever -- index is on any 'IndexedLens', 'IndexedFold', 'IndexedGetter' or 'IndexedTraversal' it is composed with. cloneIndexPreservingLens :: ALens s t a b -> IndexPreservingLens s t a b -cloneIndexPreservingLens l pafb = cotabulate $ \ws -> runPretext (l sell (extract ws)) $ \a -> corep pafb (a <$ ws) +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. @@ -503,15 +501,15 @@ -- | Modify the target of a 'Lens' and return the result. -- --- When you do not need the result of the addition, ('Control.Lens.Setter.%~') is more flexible. +-- 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) -- @ -(<%~) :: Profunctor p => Optical p q ((,) b) s t a b -> p a b -> q s (b, t) -l <%~ f = l $ rmap (\t -> (t, t)) f +(<%~) :: 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. @@ -522,7 +520,7 @@ -- ('<+~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<+~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<+~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<+~) :: Num a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <+~ a = l <%~ (+ a) {-# INLINE (<+~) #-} @@ -534,7 +532,7 @@ -- ('<-~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<-~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<-~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<-~) :: Num a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <-~ a = l <%~ subtract a {-# INLINE (<-~) #-} @@ -547,7 +545,7 @@ -- ('<*~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<*~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<*~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<*~) :: Num a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <*~ a = l <%~ (* a) {-# INLINE (<*~) #-} @@ -559,7 +557,7 @@ -- (' 'Lens'' s a -> a -> s -> (a, s) -- (' 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -( Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +( 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) => Optical (->) q ((,)a) s t a a -> e -> q s (a, t) +(<^~) :: (Num a, Integral e) => LensLike ((,)a) s t a a -> e -> s -> (a, t) l <^~ e = l <%~ (^ e) {-# INLINE (<^~) #-} @@ -585,7 +583,7 @@ -- ('<^^~') :: ('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) => Optical (->) q ((,)a) s t a a -> e -> q s (a, t) +(<^^~) :: (Fractional a, Integral e) => LensLike ((,)a) s t a a -> e -> s -> (a, t) l <^^~ e = l <%~ (^^ e) {-# INLINE (<^^~) #-} @@ -598,7 +596,7 @@ -- ('<**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<**~') :: 'Floating' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<**~) :: Floating a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<**~) :: Floating a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <**~ a = l <%~ (** a) {-# INLINE (<**~) #-} @@ -610,7 +608,7 @@ -- ('<||~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<||~') :: 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @ -(<||~) :: Optical (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t) +(<||~) :: LensLike ((,)Bool) s t Bool Bool -> Bool -> s -> (Bool, t) l <||~ b = l <%~ (|| b) {-# INLINE (<||~) #-} @@ -622,81 +620,226 @@ -- ('<&&~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<&&~') :: 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @ -(<&&~) :: Optical (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t) +(<&&~) :: 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 result of the addition, ('Control.Lens.Setter.%~') is more flexible. +-- 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) -- @ -(<<%~) :: Strong p => Optical p q ((,)a) s t a b -> p a b -> q s (a, t) +(<<%~) :: LensLike ((,)a) s t a b -> (a -> b) -> s -> (a, t) (<<%~) l = l . lmap (\a -> (a, a)) . second' {-# INLINE (<<%~) #-} --- | Modify the target of a 'Lens', but return the old value. +-- | 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. +-- 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) -- @ -(<<.~) :: Optical (->) q ((,)a) s t a b -> b -> q s (a, t) +(<<.~) :: LensLike ((,)a) s t a b -> b -> s -> (a, t) l <<.~ b = l $ \a -> (a, b) {-# INLINE (<<.~) #-} -(<<+~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +-- | 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 (<<+~) #-} -(<<-~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +-- | 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 (<<-~) #-} -(<<*~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +-- | 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 (<<*~) #-} -(< Optical' (->) q ((,) a) s a -> a -> q s (a, s) +-- | 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 (< Optical' (->) q ((,) a) s a -> e -> q s (a, s) +-- | Raise the target of a numerically valued 'Lens' to a non-negative power and return the old value. +-- +-- When you do not need the old value, ('Control.Lens.Setter.^~') is more flexible. +-- +-- @ +-- ('<<^~') :: ('Num' a, 'Integral' e) => '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 (<<^~) #-} -(<<^^~) :: (Fractional a, Integral e) => Optical' (->) q ((,) a) s a -> e -> q s (a, s) +-- | 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 (<<^^~) #-} -(<<**~) :: Floating a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +-- | 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 (<<**~) #-} -(<<||~) :: Optical' (->) q ((,) Bool) s Bool -> Bool -> q s (Bool, s) +-- | 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 (<<||~) #-} -(<<&&~) :: Optical' (->) q ((,) Bool) s Bool -> Bool -> q s (Bool, s) +-- | 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 (<<&&~) #-} -(<<<>~) :: Monoid r => Optical' (->) q ((,) r) s r -> r -> q s (r, s) -l <<<>~ b = l $ \a -> (a, a `mappend` b) +-- | 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 +-- | 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 @@ -709,12 +852,12 @@ -- ('<%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> a) -> m a -- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a -- @ -(<%=) :: (Profunctor p, MonadState s m) => Over p ((,)b) s s a b -> p a b -> m b -l <%= f = l %%= rmap (\b -> (b, b)) f +(<%=) :: 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 +-- | 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 @@ -728,7 +871,7 @@ l <+= a = l <%= (+ a) {-# INLINE (<+=) #-} --- | Subtract from the target of a numerically valued 'Lens' into your 'Monad'\'s +-- | 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 @@ -742,7 +885,7 @@ l <-= a = l <%= subtract a {-# INLINE (<-=) #-} --- | Multiply the target of a numerically valued 'Lens' into your 'Monad'\'s +-- | 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 @@ -756,7 +899,7 @@ l <*= a = l <%= (* a) {-# INLINE (<*=) #-} --- | Divide the target of a fractionally valued 'Lens' into your 'Monad'\'s state +-- | 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. @@ -769,7 +912,7 @@ l 'Lens'' s a -> (a -> a) -> m a -- ('<<%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> a) -> m a --- ('<<%=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a +-- ('<<%=') :: ('MonadState' s m, '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@ @@ -853,10 +996,10 @@ l <<%= f = l %%= lmap (\a -> (a,a)) (second' f) {-# INLINE (<<%=) #-} --- | Modify the target of a 'Lens' into your 'Monad'\'s state by a user supplied --- function and return the /old/ value that was replaced. +-- | 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', it this will return a monoidal summary of all of the old values +-- 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. @@ -864,50 +1007,157 @@ -- @ -- ('<<.=') :: 'MonadState' s m => 'Lens'' s a -> a -> m a -- ('<<.=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> a -> m a --- ('<<.=') :: ('MonadState' s m, 'Monoid' t) => 'Control.Lens.Traversal.Traversal'' s a -> a -> m a +-- ('<<.=') :: ('MonadState' s m, '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 (<<&&=) #-} -(<<<>=) :: (MonadState s m, Monoid r) => LensLike' ((,) r) s r -> r -> m r -l <<<>= b = l %%= \a -> (a, a `mappend` b) +-- | 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. @@ -926,22 +1176,58 @@ return b {-# INLINE (<<~) #-} --- | 'mappend' a monoidal value onto the end of the target of a 'Lens' and +-- | ('<>') 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. -(<<>~) :: Monoid m => Optical (->) q ((,)m) s t m m -> m -> q s (m, t) -l <<>~ m = l <%~ (`mappend` m) +(<<>~) :: Semigroup m => LensLike ((,)m) s t m m -> m -> s -> (m, t) +l <<>~ m = l <%~ (<> m) {-# INLINE (<<>~) #-} --- | 'mappend' a monoidal value onto the end of the target of a 'Lens' into --- your 'Monad'\'s state and return the result. +-- | ('<>') 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, Monoid r) => LensLike' ((,)r) s r -> r -> m r -l <<>= r = l <%= (`mappend` r) +(<<>=) :: (MonadState s m, Semigroup r) => LensLike' ((,)r) s r -> r -> m r +l <<>= r = l <%= (<> r) {-# INLINE (<<>=) #-} +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and +-- return the result. +-- However, unlike ('<<>~'), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible. +(<<>:~) :: Semigroup m => LensLike ((,) m) s t m m -> m -> s -> (m, t) +l <<>:~ m = l <%~ (m <>) +{-# INLINE (<<>:~) #-} + +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and +-- return the /old/ result. +-- However, unlike ('<<>~'), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible. +(<<<>:~) :: Semigroup m => LensLike' ((,) m) s m -> m -> s -> (m, s) +l <<<>:~ m = l <<%~ (m <>) +{-# INLINE (<<<>:~) #-} + +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into +-- your 'Monad''s state and return the result. +-- However, unlike ('<<>='), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible. +(<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r +l <<>:= r = l <%= (r <>) +{-# INLINE (<<>:=) #-} + +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into +-- your 'Monad''s state and return the /old/ result. +-- However, unlike ('<<<>='), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible. +(<<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r +l <<<>:= r = l <<%= (r <>) +{-# INLINE (<<<>:=) #-} + ------------------------------------------------------------------------------ -- Arrow operators ------------------------------------------------------------------------------ @@ -952,6 +1238,9 @@ -- '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 -- @ @@ -968,7 +1257,9 @@ -- 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@ +-- @ +-- l '<%~' f ≡ l '<%@~' 'const' f +-- @ -- -- When you do not need access to the index then ('<%~') is more liberal in what it can accept. -- @@ -978,7 +1269,7 @@ -- ('<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (b, t) -- ('<%@~') :: 'Monoid' b => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (b, t) -- @ -(<%@~) :: Optical (Indexed i) q ((,) b) s t a b -> (i -> a -> b) -> q 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 (<%@~) #-} @@ -990,7 +1281,7 @@ -- ('<<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (a, t) -- ('<<%@~') :: 'Monoid' a => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (a, t) -- @ -(<<%@~) :: Optical (Indexed i) q ((,) a) s t a b -> (i -> a -> b) -> q 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 (<<%@~) #-} @@ -999,7 +1290,9 @@ -- 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'@ +-- @ +-- ('%%@~') ≡ 'Control.Lens.Indexed.withIndex' +-- @ -- -- @ -- ('%%@~') :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t @@ -1013,7 +1306,7 @@ -- ('%%@~') :: 'IndexedLens' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- ('%%@~') :: 'Monoid' r => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- @ -(%%@~) :: IndexedLensLike i f s t a b -> (i -> a -> f b) -> s -> f t +(%%@~) :: Over (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t (%%@~) l = l .# Indexed {-# INLINE (%%@~) #-} @@ -1021,21 +1314,16 @@ -- 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)@ +-- @ +-- l '%%@=' f ≡ 'state' (l '%%@~' f) +-- @ -- -- @ -- ('%%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- ('%%@=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- @ -(%%@=) :: MonadState s m => IndexedLensLike i ((,) r) s s a b -> (i -> a -> (r, b)) -> m r -#if MIN_VERSION_mtl(2,1,0) +(%%@=) :: MonadState s m => Over (Indexed i) ((,) r) s s a b -> (i -> a -> (r, b)) -> m r l %%@= f = State.state (l %%@~ f) -#else -l %%@= f = do - (r, s) <- State.gets (l %%@~ f) - State.put s - return r -#endif {-# INLINE (%%@=) #-} -- | Adjust the target of an 'IndexedLens' returning the intermediate result, or @@ -1046,7 +1334,7 @@ -- ('<%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m b -- ('<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m b -- @ -(<%@=) :: MonadState s m => IndexedLensLike i ((,) b) s s a b -> (i -> a -> b) -> m b +(<%@=) :: 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 (<%@=) #-} @@ -1058,15 +1346,8 @@ -- ('<<%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m a -- ('<<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m a -- @ -(<<%@=) :: MonadState s m => IndexedLensLike i ((,) a) s s a b -> (i -> a -> b) -> m a -#if MIN_VERSION_mtl(2,1,0) +(<<%@=) :: 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))) -#else -l <<%@= f = do - (r, s) <- State.gets (l (Indexed $ \ i a -> (a, f i a))) - State.put s - return r -#endif {-# INLINE (<<%@=) #-} ------------------------------------------------------------------------------ @@ -1093,35 +1374,35 @@ -- -- >>> ("hello","there") & _2 #~ "world" -- ("hello","world") -( #~ ) :: ALens s t a b -> b -> s -> t -( #~ ) l b s = ipeek b (l sell s) -{-# INLINE ( #~ ) #-} +(#~) :: 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 ( #%~ ) #-} +(#%~) :: 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 ( #%%~ ) #-} +(#%%~) :: 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 () +(#=) :: MonadState s m => ALens s s a b -> b -> m () l #= f = modify (l #~ f) -{-# INLINE ( #= ) #-} +{-# INLINE (#=) #-} -- | A version of ('Control.Lens.Setter.%=') that works on 'ALens'. -( #%= ) :: MonadState s m => ALens s s a b -> (a -> b) -> m () +(#%=) :: MonadState s m => ALens s s a b -> (a -> b) -> m () l #%= f = modify (l #%~ f) -{-# INLINE ( #%= ) #-} +{-# INLINE (#%=) #-} -- | A version of ('<%~') that works on 'ALens'. -- @@ -1137,17 +1418,9 @@ {-# INLINE (<#%=) #-} -- | A version of ('%%=') that works on 'ALens'. -( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r -#if MIN_VERSION_mtl(2,1,1) +(#%%=) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r l #%%= f = State.state $ \s -> runPretext (l sell s) f -#else -l #%%= f = do - p <- State.gets (l sell) - let (r, t) = runPretext p f - State.put t - return r -#endif -{-# INLINE ( #%%= ) #-} +{-# INLINE (#%%=) #-} -- | A version of ('Control.Lens.Setter.<.~') that works on 'ALens'. -- @@ -1189,3 +1462,62 @@ 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 #-} diff --git a/src/Control/Lens/Level.hs b/src/Control/Lens/Level.hs --- a/src/Control/Lens/Level.hs +++ b/src/Control/Lens/Level.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Level --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -24,6 +27,7 @@ import Control.Lens.Internal.Indexed import Control.Lens.Internal.Level import Control.Lens.Traversal +import Control.Lens.Type import Data.Profunctor.Unsafe -- $setup @@ -31,20 +35,21 @@ -- >>> import Control.Lens -- >>> import Data.Char -levelIns :: Bazaar (->) a b t -> [Level () a] -levelIns = go 0 . (getConst #. bazaar (Const #. deepening ())) where +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 :: Bazaar (->) a b t -> [Level j b] -> t -levelOuts bz = runFlows $ runBazaar bz $ \ _ -> Flows $ \t -> case t of +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' of the individual 'levels' of any other 'Traversal' --- via iterative deepening depth-first search. The levels are returned to you in a compressed format. +-- | This 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: -- @@ -72,27 +77,41 @@ -- >>> ["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 :: ATraversal s t a b -> IndexedTraversal Int s t (Level () a) (Level () b) +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 #-} -ilevelIns :: Bazaar (Indexed i) a b t -> [Level i a] -ilevelIns = go 0 . (getConst #. bazaar (Indexed $ \ i -> Const #. deepening i)) where +-- 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 :: Bazaar (Indexed i) a b t -> [Level j b] -> t -ilevelOuts bz = runFlows $ runBazaar bz $ Indexed $ \ _ _ -> Flows $ \t -> case t of +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' of the individual levels of any other 'Traversal' --- via iterative deepening depth-first search. The levels are returned to you in a compressed format. +-- | This 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. @@ -105,9 +124,16 @@ -- >>> ["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 :: AnIndexedTraversal i s t a b -> IndexedTraversal Int s t (Level i a) (Level j b) +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 #-} diff --git a/src/Control/Lens/Loupe.hs b/src/Control/Lens/Loupe.hs deleted file mode 100644 --- a/src/Control/Lens/Loupe.hs +++ /dev/null @@ -1,43 +0,0 @@ -------------------------------------------------------------------------------- --- | --- Module : Control.Lens.Loupe --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Rank2Types --- --- This module exports a minimalist API for working with lenses in highly --- monomorphic settings. -------------------------------------------------------------------------------- -module Control.Lens.Loupe - ( - ALens, ALens' - , cloneLens - , storing - , (^#) - , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~) - , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=) - -- * Deprecated Aliases - , Loupe, SimpleLoupe - ) where - -import Control.Lens.Internal.Context -import Control.Lens.Lens -import Control.Lens.Type - --- | This is an older alias for a type-restricted form of lens that is able to be passed around --- in containers monomorphically. --- --- Deprecated. This has since been renamed to 'ALens' for consistency. -type Loupe s t a b = LensLike (Pretext (->) a b) s t a b -{-# DEPRECATED Loupe "use ALens" #-} - --- | @ --- type 'SimpleLoupe' = 'Simple' 'Loupe' --- @ --- --- Deprecated for two reasons. 'Loupe' is now 'ALens', and we no longer use the verbose @SimpleFoo@ naming --- convention, this has since been renamed to 'ALens'' for consistency. -type SimpleLoupe s a = Loupe s s a a -{-# DEPRECATED SimpleLoupe "use ALens'" #-} diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs --- a/src/Control/Lens/Operators.hs +++ b/src/Control/Lens/Operators.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Operators --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -15,16 +15,21 @@ ---------------------------------------------------------------------------- module Control.Lens.Operators ( -- output from scripts/operators -h - -- * "Control.Lens.Action" - (^!) - , (^!!) - , (^!?) - , (^@!) - , (^@!!) - , (^@!?) -- * "Control.Lens.Cons" - , (<|) + (<|) , (|>) + , (<|~) + , (<|=) + , (<<|~) + , (<<|=) + , (<<<|~) + , (<<<|=) + , (|>~) + , (|>=) + , (<|>~) + , (<|>=) + , (<<|>~) + , (<<|>=) -- * "Control.Lens.Fold" , (^..) , (^?) @@ -58,6 +63,7 @@ , (<&&~) , (<<%~) , (<<.~) + , (<~) + , (<<<>:~) , (<%=) , (<+=) , (<-=) @@ -80,6 +87,7 @@ , (<&&=) , (<<%=) , (<<.=) + , (<=) + , (<<<>:=) , (<<~) , (<<>~) , (<<>=) + , (<<>:~) + , (<<>:=) , (<%@~) , (<<%@~) , (%%@~) @@ -100,20 +111,20 @@ , (<%@=) , (<<%@=) , (^#) - , ( #~ ) - , ( #%~ ) - , ( #%%~ ) - , ( #= ) - , ( #%= ) + , (#~) + , (#%~) + , (#%%~) + , (#=) + , (#%=) , (<#%~) , (<#%=) - , ( #%%= ) + , (#%%=) , (<#~) , (<#=) -- * "Control.Lens.Plated" , (...) -- * "Control.Lens.Review" - , ( # ) + , (#) -- * "Control.Lens.Setter" , (%~) , (.~) @@ -146,6 +157,10 @@ , (~) , (<>=) + , (<>:~) + , (<>:=) + , (.@~) + , (.@=) , (%@~) , (%@=) ) where diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs --- a/src/Control/Lens/Plated.hs +++ b/src/Control/Lens/Plated.hs @@ -3,23 +3,20 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell #endif -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) 1 -#endif +#include "lens-common.h" -#ifndef MIN_VERSION_free -#define MIN_VERSION_free(x,y,z) 1 -#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Plated --- Copyright : (C) 2012-13 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -29,7 +26,7 @@ -- 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 @@ -67,12 +64,13 @@ , 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 @@ -80,35 +78,42 @@ -- * Parts , parts + + -- * Generics + , gplate + , gplate1 + , GPlated + , GPlated1 ) where -import Control.Applicative +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 -#if !(MIN_VERSION_free(4,6,0)) -import Control.MonadPlus.Free as MonadPlus -#endif import qualified Language.Haskell.TH as TH -import Data.Aeson -import Data.Bitraversable import Data.Data import Data.Data.Lens -import Data.Monoid import Data.Tree +import GHC.Generics -#ifdef HLINT -{-# ANN module "HLint: ignore Reduce duplication" #-} -#endif +-- $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. -- @@ -127,7 +132,7 @@ -- = Val 'Int' -- | Neg Expr -- | Add Expr Expr --- deriving ('Eq','Ord','Show','Read','Data','Typeable') +-- deriving ('Eq','Ord','Show','Read','Data') -- @ -- -- @ @@ -158,7 +163,7 @@ -- data Tree a -- = Bin (Tree a) (Tree a) -- | Tip a --- deriving ('Eq','Ord','Show','Read','Data','Typeable') +-- deriving ('Eq','Ord','Show','Read','Data') -- @ -- -- @ @@ -205,10 +210,8 @@ -- 'plate' will default to 'uniplate' and you can choose to not override -- it with your own definition. plate :: Traversal' a a -#ifndef HLINT default plate :: Data a => Traversal' a a plate = uniplate -#endif instance Plated [a] where plate f (x:xs) = (x:) <$> f xs @@ -219,14 +222,7 @@ plate _ x = pure x instance (Traversable f, Traversable m) => Plated (Trans.FreeT f m a) where - plate f (Trans.FreeT xs) = Trans.FreeT <$> traverse (bitraverse pure f) xs - -#if !(MIN_VERSION_free(4,6,0)) -instance Traversable f => Plated (MonadPlus.Free f a) where - plate f (MonadPlus.Free as) = MonadPlus.Free <$> traverse f as - plate f (MonadPlus.Plus as) = MonadPlus.Plus <$> traverse f as - plate _ x = pure x -#endif + 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 @@ -236,26 +232,20 @@ -- 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 -instance Plated Value where - plate f (Object o) = Object <$> traverse f o - plate f (Array a) = Array <$> traverse f a - plate _ xs = pure xs - {-# INLINE plate #-} - {- Default uniplate instances -} instance Plated TH.Exp instance Plated TH.Dec instance Plated TH.Con instance Plated TH.Type -#if !(MIN_VERSION_template_haskell(2,8,0)) -instance Plated TH.Kind -- in 2.8 Kind is an alias for Type -#endif instance Plated TH.Stmt instance Plated TH.Pat @@ -266,6 +256,19 @@ 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 ------------------------------------------------------------------------------- @@ -292,7 +295,7 @@ -- -- Usually 'transform' is more appropriate, but 'rewrite' can give better -- compositionality. Given two single transformations @f@ and @g@, you can --- construct @\a -> f a `mplus` g a@ which performs both rewrites until a fixed point. +-- 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 #-} @@ -306,7 +309,7 @@ -- -- Usually 'transformOf' is more appropriate, but 'rewriteOf' can give better -- compositionality. Given two single transformations @f@ and @g@, you can --- construct @\a -> f a `mplus` g a@ which performs both rewrites until a fixed point. +-- 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 @@ -314,7 +317,7 @@ -- 'rewriteOf' :: 'Traversal'' a a -> (a -> 'Maybe' a) -> a -> a -- 'rewriteOf' :: 'Setter'' a a -> (a -> 'Maybe' a) -> a -> a -- @ -rewriteOf :: ASetter' a a -> (a -> Maybe a) -> a -> a +rewriteOf :: 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 #-} @@ -334,12 +337,12 @@ -- | Rewrite recursively over part of a larger structure using a specified 'Setter'. -- -- @ --- 'rewriteOnOf' :: 'Plated' a => 'Control.Lens.Iso.Iso'' s a -> 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> s -> s --- 'rewriteOnOf' :: 'Plated' a => 'Lens'' s a -> 'Lens'' a a -> (a -> 'Maybe' a) -> s -> s --- 'rewriteOnOf' :: 'Plated' a => 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s --- 'rewriteOnOf' :: 'Plated' a => 'Setter'' s a -> 'Setter'' a a -> (a -> 'Maybe' a) -> s -> s +-- 'rewriteOnOf' :: '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 a -> ASetter' a a -> (a -> Maybe a) -> s -> t +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 #-} @@ -351,7 +354,7 @@ -- | Rewrite by applying a monadic rule everywhere you recursing with a user-specified 'Traversal'. -- Ensures that the rule cannot be applied anywhere in the result. -rewriteMOf :: Monad m => LensLike' (WrappedMonad m) a a -> (a -> m (Maybe a)) -> a -> m a +rewriteMOf :: 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 #-} @@ -364,7 +367,7 @@ -- | Rewrite by applying a monadic rule everywhere inside of a structure located by a user-specified 'Traversal', -- using a user-specified 'Traversal' for recursion. Ensures that the rule cannot be applied anywhere in the result. -rewriteMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m (Maybe a)) -> s -> m t +rewriteMOnOf :: 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 #-} @@ -382,13 +385,18 @@ -- @ -- 'universeOf' :: 'Fold' a a -> a -> [a] -- @ -universeOf :: Getting [a] a a -> a -> [a] -universeOf l = go where - go a = a : foldMapOf l go 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 [a] s a -> s -> [a] +universeOn :: Plated a => Getting (Endo [a]) s a -> s -> [a] universeOn b = universeOnOf b plate {-# INLINE universeOn #-} @@ -398,10 +406,45 @@ -- @ -- 'toListOf' l ≡ 'universeOnOf' l 'ignored' -- @ -universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a] -universeOnOf b = foldMapOf b . universeOf +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 ------------------------------------------------------------------------------- @@ -435,7 +478,7 @@ -- 'transformOf' :: 'Traversal'' a a -> (a -> a) -> a -> a -- 'transformOf' :: 'Setter'' a a -> (a -> a) -> a -> a -- @ -transformOf :: ASetter' a a -> (a -> a) -> a -> a +transformOf :: ASetter a b a b -> (b -> b) -> a -> b transformOf l f = go where go = f . over l go {-# INLINE transformOf #-} @@ -447,7 +490,7 @@ -- 'transformOnOf' :: 'Setter'' s a -> 'Traversal'' a a -> (a -> a) -> s -> s -- 'transformOnOf' :: 'Setter'' s a -> 'Setter'' a a -> (a -> a) -> s -> s -- @ -transformOnOf :: ASetter s t a a -> ASetter' a a -> (a -> a) -> s -> t +transformOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> b) -> s -> t transformOnOf b l = over b . transformOf l {-# INLINE transformOnOf #-} @@ -470,7 +513,7 @@ -- @ -- 'transformMOf' :: 'Monad' m => 'Traversal'' a a -> (a -> m a) -> a -> m a -- @ -transformMOf :: Monad m => LensLike' (WrappedMonad m) a a -> (a -> m a) -> a -> m a +transformMOf :: 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 #-} @@ -481,7 +524,7 @@ -- @ -- 'transformMOnOf' :: 'Monad' m => 'Traversal'' s a -> 'Traversal'' a a -> (a -> m a) -> s -> m s -- @ -transformMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m a) -> s -> m t +transformMOnOf :: 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 #-} @@ -577,7 +620,7 @@ -- 'holesOn' :: 'IndexedLens'' i s a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s] -- 'holesOn' :: 'IndexedTraversal'' i s a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s] -- @ -holesOn :: Conjoined p => Optical p (->) (Bazaar p a a) s t a a -> s -> [Pretext p a a t] +holesOn :: Conjoined p => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t] holesOn = holesOf {-# INLINE holesOn #-} @@ -596,7 +639,7 @@ -- @ holesOnOf :: Conjoined p => LensLike (Bazaar p r r) s t a b - -> Optical p (->) (Bazaar p r r) a b r r + -> Over p (Bazaar p r r) a b r r -> s -> [Pretext p r r t] holesOnOf b l = holesOf (b . l) {-# INLINE holesOnOf #-} @@ -637,7 +680,7 @@ -- -- @ -- 'composOpMonoid' ≡ 'foldMapOf' 'plate' --- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'to' f) +-- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'Control.Lens.Getter.to' f) -- 'composOp' ≡ 'descend' ≡ 'over' 'plate' -- 'composOpM' ≡ 'descendM' ≡ 'mapMOf' 'plate' -- 'composOpM_' ≡ 'descendM_' ≡ 'mapMOf_' 'plate' @@ -667,3 +710,147 @@ 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' #-} diff --git a/src/Control/Lens/Prism.hs b/src/Control/Lens/Prism.hs --- a/src/Control/Lens/Prism.hs +++ b/src/Control/Lens/Prism.hs @@ -4,10 +4,13 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif + +#include "lens-common.h" + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Prism --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -23,12 +26,15 @@ , prism , prism' -- * Consuming Prisms + , withPrism , clonePrism , outside , aside , without , below , isn't + , matching + , matching' -- * Common Prisms , _Left , _Right @@ -38,28 +44,28 @@ , _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 Data.Functor.Identity -import Data.Profunctor +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.List as List import Data.Profunctor.Rep -import Data.Traversable -import Data.Void -#ifndef SAFE -import Unsafe.Coerce -#else -import Data.Profunctor.Unsafe -#endif - -{-# ANN module "HLint: ignore Use camelCase" #-} +import qualified Data.Text as TS +import qualified Data.Text.Lazy as TL -- $setup -- >>> :set -XNoOverloadedStrings @@ -85,21 +91,16 @@ type APrism' s a = APrism s s a a -- | Convert 'APrism' to the pair of functions that characterize it. -runPrism :: APrism s t a b -> Market a b s t -#ifdef SAFE -runPrism k = case k (Market Identity Right) of - Market bt seta -> Market (runIdentity #. bt) (either (Left . runIdentity) Right . seta) -#else -runPrism k = unsafeCoerce (k (Market Identity Right)) -#endif -{-# INLINE runPrism #-} +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 = case runPrism k of - Market bt seta -> prism bt seta +clonePrism k = withPrism k $ \bt sta -> prism bt sta {-# INLINE clonePrism #-} ------------------------------------------------------------------------------ @@ -126,8 +127,8 @@ -- TODO: can we make this work with merely Strong? outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r) -outside k = case runPrism k of - Market bt seta -> \f ft -> f (lmap bt ft) <&> \fa -> tabulate $ either (rep ft) (rep fa) . seta +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. @@ -136,26 +137,38 @@ without :: APrism s t a b -> APrism u v c d -> Prism (Either s u) (Either t v) (Either a c) (Either b d) -without k = case runPrism k of - Market bt seta -> \ k' -> case runPrism k' of - Market dv uevc -> prism (bimap bt dv) $ \su -> case su of - Left s -> bimap Left Left (seta s) - Right u -> bimap Right Right (uevc u) +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 = case runPrism k of - Market bt seta -> prism (fmap bt) $ \(e,s) -> case seta s of +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 = case runPrism k of - Market bt seta -> prism (fmap bt) $ \s -> case traverse seta s of +below k = + withPrism k $ \bt seta -> + prism (fmap bt) $ \s -> + case traverse seta s of Left _ -> Left s Right t -> Right t {-# INLINE below #-} @@ -170,13 +183,49 @@ -- -- >>> 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 runPrism k of - Market _ seta -> case seta s of - Left _ -> True +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 ------------------------------------------------------------------------------ @@ -294,14 +343,24 @@ {-# INLINE only #-} --- | This 'Prism' compares for approximate equality with a given value and a predicate for testing. +-- | 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 #-} @@ -325,3 +384,71 @@ [(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 #-} diff --git a/src/Control/Lens/Profunctor.hs b/src/Control/Lens/Profunctor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Profunctor.hs @@ -0,0 +1,135 @@ +{-# 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 diff --git a/src/Control/Lens/Reified.hs b/src/Control/Lens/Reified.hs --- a/src/Control/Lens/Reified.hs +++ b/src/Control/Lens/Reified.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,7 +6,7 @@ ------------------------------------------------------------------------------ -- | -- Module : Control.Lens.Reified --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -28,22 +29,28 @@ 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 'Lens' so it can be stored safely in a container. +-- | 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 } -- | @ @@ -55,7 +62,7 @@ -- IndexedLens ------------------------------------------------------------------------------ --- | Reify an 'IndexedLens' so it can be stored safely in a container. +-- | 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 } -- | @ @@ -67,7 +74,7 @@ -- IndexedTraversal ------------------------------------------------------------------------------ --- | Reify an 'IndexedTraversal' so it can be stored safely in a container. +-- | 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 } -- | @ @@ -79,7 +86,7 @@ -- Traversal ------------------------------------------------------------------------------ --- | A form of 'Traversal' that can be stored monomorphically in a container. +-- | 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 } -- | @ @@ -91,7 +98,7 @@ -- Getter ------------------------------------------------------------------------------ --- | Reify a 'Getter' so it can be stored safely in a container. +-- | 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. @@ -148,7 +155,7 @@ {-# INLINE (>>-) #-} instance Monad (ReifiedGetter s) where - return a = Getter $ to $ \_ -> a + return = pure {-# INLINE return #-} Getter ma >>= f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s {-# INLINE (>>=) #-} @@ -167,24 +174,34 @@ 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) - corep (Getter l) = view l . runIdentity +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) - rep (Getter l) = Identity . view l +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) -> - coerce $ runGetter l (dimap (flip (,) c) coerce f) s + phantom $ runGetter l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = Getter $ \f (c,s) -> - coerce $ runGetter l (dimap ((,) c) coerce f) s + phantom $ runGetter l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice ReifiedGetter where @@ -232,26 +249,28 @@ -- IndexedGetter ------------------------------------------------------------------------------ --- | Reify an 'IndexedGetter' so it can be stored safely in a container. +-- | 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 #-} - rep = iview . runIndexedGetter - {-# INLINE rep #-} instance Strong (ReifiedIndexedGetter i) where first' l = IndexedGetter $ \f (s,c) -> - coerce $ runIndexedGetter l (dimap (flip (,) c) coerce f) s + phantom $ runIndexedGetter l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = IndexedGetter $ \f (c,s) -> - coerce $ runIndexedGetter l (dimap ((,) c) coerce f) s + phantom $ runIndexedGetter l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Functor (ReifiedIndexedGetter i s) where @@ -262,14 +281,15 @@ IndexedGetter mf <.> IndexedGetter ma = IndexedGetter $ \k s -> case iview mf s of (i, f) -> case iview ma s of - (j, a) -> coerce $ indexed k (i <> j) (f a) + (j, a) -> phantom $ indexed k (i <> j) (f a) {-# INLINE (<.>) #-} + ------------------------------------------------------------------------------ -- Fold ------------------------------------------------------------------------------ --- | Reify a 'Fold' so it can be stored safely in a container. +-- | 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 @@ -287,17 +307,19 @@ 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) - rep = toListOf . runFold instance Strong ReifiedFold where first' l = Fold $ \f (s,c) -> - coerce $ runFold l (dimap (flip (,) c) coerce f) s + phantom $ runFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = Fold $ \f (c,s) -> - coerce $ runFold l (dimap ((,) c) coerce f) s + phantom $ runFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice ReifiedFold where @@ -370,7 +392,7 @@ {-# INLINE (>>-) #-} instance Monad (ReifiedFold s) where - return a = Fold $ folding $ \_ -> [a] + return = pure {-# INLINE return #-} Fold ma >>= f = Fold $ folding $ \s -> toListOf ma s >>= \a -> toListOf (runFold (f a)) s {-# INLINE (>>=) #-} @@ -394,8 +416,10 @@ 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 () = (<|>) @@ -418,8 +442,10 @@ 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 $ @@ -442,26 +468,29 @@ 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 -> coerce . traverse_ (coerce . uncurry (indexed f)) . getCompose . k + tabulate k = IndexedFold $ \f -> phantom . traverse_ (phantom . uncurry (indexed f)) . getCompose . k {-# INLINE tabulate #-} - rep (IndexedFold l) = Compose . itoListOf l - {-# INLINE rep #-} instance Strong (ReifiedIndexedFold i) where first' l = IndexedFold $ \f (s,c) -> - coerce $ runIndexedFold l (dimap (flip (,) c) coerce f) s + phantom $ runIndexedFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = IndexedFold $ \f (c,s) -> - coerce $ runIndexedFold l (dimap ((,) c) coerce f) s + phantom $ runIndexedFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} + ------------------------------------------------------------------------------ -- Setter ------------------------------------------------------------------------------ --- | Reify a 'Setter' so it can be stored safely in a container. +-- | 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 } -- | @ @@ -473,7 +502,7 @@ -- IndexedSetter ------------------------------------------------------------------------------ --- | Reify an 'IndexedSetter' so it can be stored safely in a container. +-- | 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 } @@ -486,7 +515,7 @@ -- Iso ------------------------------------------------------------------------------ --- | Reify an 'Iso' so it can be stored safely in a container. +-- | 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 } -- | @ @@ -498,7 +527,7 @@ -- Prism ------------------------------------------------------------------------------ --- | Reify a 'Prism' so it can be stored safely in a container. +-- | 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 } -- | @ diff --git a/src/Control/Lens/Review.hs b/src/Control/Lens/Review.hs --- a/src/Control/Lens/Review.hs +++ b/src/Control/Lens/Review.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif + +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-trustworthy-safe #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Review --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -18,24 +18,24 @@ module Control.Lens.Review ( -- * Reviewing - Review, Review' - , AReview, AReview' + 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.Internal.Setter import Control.Lens.Type import Data.Bifunctor import Data.Functor.Identity @@ -47,7 +47,9 @@ -- $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 @@ -57,24 +59,6 @@ -- Review ------------------------------------------------------------------------------ --- | This is a limited form of a 'Prism' that can only be used for 're' operations. --- --- Like with a 'Getter', there are no laws to state for a 'Review'. --- --- You can generate a 'Review' by using 'unto'. You can also use any 'Prism' or 'Iso' --- directly as a 'Review'. -type Review s t a b = forall p f. (Profunctor p, Bifunctor p, Settable f) => Optic p f s t a b - --- | A 'Simple' 'Review' -type Review' t b = Review t t b b - --- | If you see this in a signature for a function, the function is expecting a 'Review' --- (in practice, this usually means a 'Prism'). -type AReview s t a b = Optic Tagged Identity s t a b - --- | A 'Simple' 'AReview' -type AReview' t b = AReview t t b b - -- | An analogue of 'to' for 'review'. -- -- @ @@ -122,7 +106,7 @@ -- 're' :: 'Prism' s t a b -> 'Getter' b t -- 're' :: 'Iso' s t a b -> 'Getter' b t -- @ -re :: AReview s t a b -> Getter b t +re :: AReview t b -> Getter b t re p = to (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE re #-} @@ -147,14 +131,14 @@ -- 'review' :: 'Prism'' s a -> a -> s -- @ -- --- However, when working with a 'Monad' transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of --- these more slightly more liberal type signatures may be beneficial to think of it as having: +-- 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 s t a b -> m t +review :: MonadReader b m => AReview t b -> m t review p = asks (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE review #-} @@ -178,12 +162,12 @@ -- @ -- (#) :: 'Iso'' s a -> a -> s -- (#) :: 'Prism'' s a -> a -> s --- (#) :: 'Review'' s a -> a -> s +-- (#) :: 'Review' s a -> a -> s -- (#) :: 'Equality'' s a -> a -> s -- @ -( # ) :: AReview s t a b -> b -> t -( # ) p = runIdentity #. unTagged #. p .# Tagged .# Identity -{-# INLINE ( # ) #-} +(#) :: 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. @@ -207,14 +191,14 @@ -- 'reviews' :: 'Prism'' s a -> (s -> r) -> a -> r -- @ -- --- However, when working with a 'Monad' transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of --- these more slightly more liberal type signatures may be beneficial to think of it as having: +-- 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 s t a b -> (t -> 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 #-} @@ -235,7 +219,7 @@ -- 'reuse' :: 'MonadState' a m => 'Prism'' s a -> m s -- 'reuse' :: 'MonadState' a m => 'Iso'' s a -> m s -- @ -reuse :: MonadState b m => AReview s t a b -> m t +reuse :: MonadState b m => AReview t b -> m t reuse p = gets (runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE reuse #-} @@ -254,6 +238,16 @@ -- 'reuses' :: 'MonadState' a m => 'Prism'' s a -> (s -> r) -> m r -- 'reuses' :: 'MonadState' a m => 'Iso'' s a -> (s -> r) -> m r -- @ -reuses :: MonadState b m => AReview s t a b -> (t -> r) -> m r +reuses :: 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 diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs --- a/src/Control/Lens/Setter.hs +++ b/src/Control/Lens/Setter.hs @@ -3,13 +3,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Setter --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -50,22 +49,24 @@ , over , set , (.~), (%~) - , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (~), (<>:~), (&&~), (<.~), (?~), (=), (&&=), (<.=), (?=), (=), (<>:=), (&&=), (<.=), (?=), (>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Char --- >>> import Data.Map as Map +-- >>> 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 = Vars.f --- >>> let g :: Expr -> Expr; g = Vars.g --- >>> let h :: Expr -> Expr -> Expr; h = Vars.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" -- >>> :set -XNoOverloadedStrings -infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, =, ||=, %=, <.=, ?=, ~, <>:~, ||~, %~, <.~, ?~, =, <>:=, ||=, %=, <.=, ?=, b) -> s -> t) -> 'Setter' s t a b -- @ setting :: ((a -> b) -> s -> t) -> IndexPreservingSetter s t a b -setting l pafb = cotabulate $ \ws -> pure $ l (\a -> untainted (corep pafb (a <$ ws))) (extract ws) +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'. @@ -291,13 +288,13 @@ -- | Restore 'ASetter' to a full 'Setter'. cloneSetter :: ASetter s t a b -> Setter s t a b -cloneSetter l afb = taintedDot $ runIdentity #. l (Identity #. untaintedDot afb) +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 (corep pafb (a <$ ws)))) (extract ws) + taintedDot runIdentity $ l (\a -> Identity (untainted (cosieve pafb (a <$ ws)))) (extract ws) {-# INLINE cloneIndexPreservingSetter #-} -- | Clone an 'IndexedSetter'. @@ -349,8 +346,8 @@ -- 'over' :: 'Setter' s t a b -> (a -> b) -> s -> t -- 'over' :: 'ASetter' s t a b -> (a -> b) -> s -> t -- @ -over :: Profunctor p => Setting p s t a b -> p a b -> s -> t -over l f = runIdentity #. l (Identity #. f) +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' @@ -440,7 +437,7 @@ -- ('%~') :: 'Lens' s t a b -> (a -> b) -> s -> t -- ('%~') :: 'Traversal' s t a b -> (a -> b) -> s -> t -- @ -(%~) :: Profunctor p => Setting p s t a b -> p a b -> s -> t +(%~) :: ASetter s t a b -> (a -> b) -> s -> t (%~) = over {-# INLINE (%~) #-} @@ -484,6 +481,11 @@ -- >>> 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 @@ -496,7 +498,7 @@ -- | Set with pass-through. -- --- This is mostly present for consistency, but may be useful for for chaining assignments. +-- 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. -- @@ -525,7 +527,7 @@ -- -- If you do not need a copy of the intermediate result, then using @l '?~' d@ directly is a good idea. -- --- >>> import Data.Map as Map +-- >>> import qualified Data.Map as Map -- >>> _2.at "hello" 'ASetter' s s a b -> (a -> b) -> m () -- @ -(%=) :: (Profunctor p, MonadState s m) => Setting p s s a b -> p 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. -- @@ -1024,7 +1031,7 @@ return b {-# INLINE (')@. -- -- >>> (Sum a,b) & _1 <>~ Sum c -- (Sum {getSum = a + c},b) @@ -1036,16 +1043,16 @@ -- ("hello!!!","world!!!") -- -- @ --- ('<>~') :: 'Monoid' a => 'Setter' s t a a -> a -> s -> t --- ('<>~') :: 'Monoid' a => 'Iso' s t a a -> a -> s -> t --- ('<>~') :: 'Monoid' a => 'Lens' s t a a -> a -> s -> t --- ('<>~') :: 'Monoid' a => 'Traversal' s t a a -> a -> s -> t +-- ('<>~') :: '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 -- @ -(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t -l <>~ n = over l (`mappend` n) +(<>~) :: 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 'mappend'ing a value. +-- | 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}) @@ -1054,25 +1061,43 @@ -- ("hello!!!","world!!!") -- -- @ --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Setter'' s a -> a -> m () --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Iso'' s a -> a -> m () --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Lens'' s a -> a -> m () --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Traversal'' s a -> a -> m () +-- ('<>=') :: ('MonadState' s m, '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, Monoid a) => ASetter' s a -> a -> m () +(<>=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m () l <>= a = State.modify (l <>~ a) {-# INLINE (<>=) #-} +-- | Modify the target of a 'Semigroup' value by using @('<>')@. +-- However, unlike '<>~', it is prepend to the head side. +-- +-- >>> ["world"] & id <>:~ ["hello"] +-- ["hello","world"] +-- +-- >>> (["world"], ["lens"]) & _1 <>:~ ["hello"] +-- (["hello","world"],["lens"]) +(<>:~) :: Semigroup b => ASetter s t b b -> b -> s -> t +l <>:~ n = over l (n <>) +{-# INLINE (<>:~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('<>')@. +-- However, unlike '<>=', it is prepend to the head side. +(<>:=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m () +l <>:= a = State.modify (l <>:~ a) +{-# INLINE (<>:=) #-} + ----------------------------------------------------------------------------- -- Writer Operations ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- -- | Write to a fragment of a larger 'Writer' format. scribe :: (MonadWriter t m, Monoid s) => ASetter s t a b -> b -> m () scribe l b = tell (set l b mempty) {-# INLINE scribe #-} --- | This is a generalization of 'pass' that alows you to modify just a +-- | 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 @@ -1080,7 +1105,7 @@ return (a, over l uv) {-# INLINE passing #-} --- | This is a generalization of 'pass' that alows you to modify just a +-- | 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 @@ -1089,13 +1114,13 @@ return (a, iover l uv) {-# INLINE ipassing #-} --- | This is a generalization of 'censor' that alows you to 'censor' just a +-- | 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 alows you to 'censor' just a +-- | 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 @@ -1103,8 +1128,54 @@ {-# 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'. @@ -1122,9 +1193,26 @@ -- 'iover' :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ iover :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t -iover l = over l .# Indexed +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: @@ -1141,8 +1229,8 @@ -- 'iover' '.' 'isets' ≡ 'id' -- @ -- --- Another way to view 'sets' is that it takes a \"semantic editor combinator\" --- and transforms it into a 'Setter'. +-- 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 #-} @@ -1151,10 +1239,10 @@ -- with access to the index. -- -- @ --- ('%@~') ≡ 'imapOf' +-- ('%@~') ≡ 'iover' -- @ -- --- When you do not need access to the index then ('%@~') is more liberal in what it can accept. +-- When you do not need access to the index then ('%~') is more liberal in what it can accept. -- -- @ -- l '%~' f ≡ l '%@~' 'const' f @@ -1166,9 +1254,31 @@ -- ('%@~') :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ (%@~) :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t -l %@~ f = l %~ Indexed f +(%@~) = 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. -- @@ -1187,6 +1297,29 @@ 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 ------------------------------------------------------------------------------ @@ -1227,7 +1360,7 @@ ------------------------------------------------------------------------------ -- | 'mapOf' is a deprecated alias for 'over'. -mapOf :: Profunctor p => Setting p s t a b -> p a b -> s -> t +mapOf :: ASetter s t a b -> (a -> b) -> s -> t mapOf = over {-# INLINE mapOf #-} {-# DEPRECATED mapOf "Use `over`" #-} diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -1,1465 +1,873 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif - -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.TH --- Copyright : (C) 2012-14 Edward Kmett, Michael Sloan --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Control.Lens.TH - ( - -- * Constructing Lenses Automatically - makeLenses, makeLensesFor - , makeClassy, makeClassyFor, makeClassy_ - , makeIso - , makePrisms - , makeWrapped - , makeFields - -- * Constructing Lenses Given a Declaration Quote - , declareLenses, declareLensesFor - , declareClassy, declareClassyFor - , declareIso - , declarePrisms - , declareWrapped - , declareFields - -- * Configuring Lenses - , makeLensesWith - , makeFieldsWith - , declareLensesWith - , declareFieldsWith - , defaultRules - , defaultFieldRules - , camelCaseFields - , underscoreFields - , LensRules(LensRules) - , FieldRules(FieldRules) - , lensRules - , classyRules - , classyRules_ - , isoRules - , lensIso - , lensField - , lensClass - , lensFlags - , LensFlag(..) - , simpleLenses - , partialLenses - , buildTraversals - , handleSingletons - , singletonIso - , backwardIso - , singletonRequired - , createClass - , createInstance - , classRequired - , singletonAndField - , generateSignatures - ) where - -import Control.Applicative -import Control.Monad ((<=<), when, replicateM) -#if !(MIN_VERSION_template_haskell(2,7,0)) -import Control.Monad (ap) -#endif -import qualified Control.Monad.Trans as Trans -import Control.Monad.Trans.Writer -import Control.Lens.At -import Control.Lens.Fold -import Control.Lens.Getter -import Control.Lens.Iso -import Control.Lens.Lens -import Control.Lens.Prism -import Control.Lens.Review -import Control.Lens.Setter -import Control.Lens.Tuple -import Control.Lens.Traversal -import Control.Lens.Wrapped -import Control.Lens.Internal.TH -import Data.Char (toLower, toUpper, isUpper) -import Data.Either (lefts) -import Data.Foldable hiding (concat, any) -import Data.Function (on) -import Data.List as List -import Data.Map as Map hiding (toList,map,filter) -import Data.Maybe as Maybe (isNothing,isJust,catMaybes,fromJust,mapMaybe) -import Data.Monoid -import Data.Ord (comparing) -import Data.Set as Set hiding (toList,map,filter) -import Data.Set.Lens -import Data.Traversable hiding (mapM) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Lens - -#ifdef HLINT -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Use fewer imports" #-} -{-# ANN module "HLint: ignore Use foldl" #-} -#endif - --- | Flags for 'Lens' construction -data LensFlag - = SimpleLenses - | PartialLenses - | BuildTraversals - | SingletonAndField - | SingletonIso - | BackwardIso - | HandleSingletons - | SingletonRequired - | CreateClass - | CreateInstance - | ClassRequired - | GenerateSignatures - deriving (Eq,Ord,Show,Read) - --- | Only Generate valid 'Control.Lens.Type.Simple' lenses. -simpleLenses :: Lens' LensRules Bool -simpleLenses = lensFlags.contains SimpleLenses - --- | Enables the generation of partial lenses, generating runtime errors for --- every constructor that does not have a valid definition for the 'Lens'. This --- occurs when the constructor lacks the field, or has multiple fields mapped --- to the same 'Lens'. -partialLenses :: Lens' LensRules Bool -partialLenses = lensFlags.contains PartialLenses - --- | In the situations that a 'Lens' would be partial, when 'partialLenses' is --- used, this flag instead causes traversals to be generated. Only one can be --- used, and if neither are, then compile-time errors are generated. -buildTraversals :: Lens' LensRules Bool -buildTraversals = lensFlags.contains BuildTraversals - --- | Handle singleton constructors specially. -handleSingletons :: Lens' LensRules Bool -handleSingletons = lensFlags.contains HandleSingletons - --- | When building a singleton 'Iso' (or 'Lens') for a record constructor, build --- both the 'Iso' (or 'Lens') for the record and the one for the field. -singletonAndField :: Lens' LensRules Bool -singletonAndField = lensFlags.contains SingletonAndField - --- | Use 'Iso' for singleton constructors. -singletonIso :: Lens' LensRules Bool -singletonIso = lensFlags.contains SingletonIso - --- | When generating an 'Iso' put the field type as the "outer" type. -backwardIso :: Lens' LensRules Bool -backwardIso = lensFlags.contains BackwardIso - --- | Expect a single constructor, single field newtype or data type. -singletonRequired :: Lens' LensRules Bool -singletonRequired = lensFlags.contains SingletonRequired - --- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the 'lensClass' rule matches. -createClass :: Lens' LensRules Bool -createClass = lensFlags.contains CreateClass - --- | Create the instance if the constructor is 'Control.Lens.Type.Simple' and the 'lensClass' rule matches. -createInstance :: Lens' LensRules Bool -createInstance = lensFlags.contains CreateInstance - --- | Die if the 'lensClass' fails to match. -classRequired :: Lens' LensRules Bool -classRequired = lensFlags.contains ClassRequired - --- | Indicate whether or not to supply the signatures for the generated --- lenses. --- --- Disabling this can be useful if you want to provide a more restricted type --- signature or if you want to supply hand-written haddocks. -generateSignatures :: Lens' LensRules Bool -generateSignatures = lensFlags.contains GenerateSignatures - --- | This configuration describes the options we'll be using to make --- isomorphisms or lenses. -data LensRules = LensRules - { _lensIso :: String -> Maybe String - , _lensField :: String -> Maybe String - , _lensClass :: String -> Maybe (String, String) - , _lensFlags :: Set LensFlag - } - --- | 'Lens'' to access the convention for naming top level isomorphisms in our --- 'LensRules'. --- --- Defaults to lowercasing the first letter of the constructor. -lensIso :: Lens' LensRules (String -> Maybe String) -lensIso f (LensRules i n c o) = f i <&> \i' -> LensRules i' n c o - --- | 'Lens'' to access the convention for naming fields in our 'LensRules'. --- --- Defaults to stripping the _ off of the field name, lowercasing the name, and --- rejecting the field if it doesn't start with an '_'. -lensField :: Lens' LensRules (String -> Maybe String) -lensField f (LensRules i n c o) = f n <&> \n' -> LensRules i n' c o - --- | Retrieve options such as the name of the class and method to put in it to --- build a class around monomorphic data types. -lensClass :: Lens' LensRules (String -> Maybe (String, String)) -lensClass f (LensRules i n c o) = f c <&> \c' -> LensRules i n c' o - --- | Retrieve options such as the name of the class and method to put in it to --- build a class around monomorphic data types. -lensFlags :: Lens' LensRules (Set LensFlag) -lensFlags f (LensRules i n c o) = f o <&> LensRules i n c - --- | Default 'LensRules'. -defaultRules :: LensRules -defaultRules = LensRules mLowerName fld (const Nothing) $ - Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance, BuildTraversals, GenerateSignatures] - where - fld ('_':cs) = mLowerName cs - fld _ = Nothing - -mLowerName :: String -> Maybe String -mLowerName (c:cs) = Just (toLower c:cs) -mLowerName _ = Nothing - --- | Rules for making fairly simple partial lenses, ignoring the special cases --- for isomorphisms and traversals, and not making any classes. -lensRules :: LensRules -lensRules = defaultRules - & lensIso .~ const Nothing - & lensClass .~ const Nothing - & handleSingletons .~ True - & partialLenses .~ False - & buildTraversals .~ True - -lensRulesFor :: [(String, String)] -> LensRules -lensRulesFor fields = lensRules & lensField .~ (`Prelude.lookup` fields) - --- | Rules for making lenses and traversals that precompose another 'Lens'. -classyRules :: LensRules -classyRules = defaultRules - & lensIso .~ const Nothing - & handleSingletons .~ False - & lensClass .~ classy - & classRequired .~ True - & partialLenses .~ False - & buildTraversals .~ True - where - classy :: String -> Maybe (String, String) - classy n@(a:as) = Just ("Has" ++ n, toLower a:as) - classy _ = Nothing - -classyRulesFor - :: (String -> Maybe (String, String)) -> [(String, String)] -> LensRules -classyRulesFor classFun fields = classyRules - & lensClass .~ classFun - & lensField .~ (`Prelude.lookup` fields) - -underscorePrefixRules :: LensRules -underscorePrefixRules = LensRules mLowerName fld (const Nothing) $ - Set.fromList [SingletonIso, SingletonAndField, CreateClass, - CreateInstance, BuildTraversals, GenerateSignatures] - where - fld cs = Just ('_':cs) - -classyRules_ :: LensRules -classyRules_ = underscorePrefixRules - & lensIso .~ const Nothing - & handleSingletons .~ False - & lensClass .~ classy - & classRequired .~ True - & partialLenses .~ False - & buildTraversals .~ True - where - classy :: String -> Maybe (String, String) - classy n@(a:as) = Just ("Has" ++ n, toLower a:as) - classy _ = Nothing - --- | Rules for making an isomorphism from a data type. -isoRules :: LensRules -isoRules = defaultRules - & handleSingletons .~ True - & singletonRequired .~ True - & singletonAndField .~ True - & backwardIso .~ True - --- | Build lenses (and traversals) with a sensible default configuration. --- --- /e.g./ --- --- @ --- data FooBar --- = Foo { _x, _y :: 'Int' } --- | Bar { _x :: 'Int' } --- 'makeLenses' ''FooBar --- @ --- --- will create --- --- @ --- x :: 'Lens'' FooBar 'Int' --- x f (Foo a b) = (\a\' -> Foo a\' b) \<$\> f a --- x f (Bar a) = Bar \<$\> f a --- y :: 'Traversal'' FooBar 'Int' --- y f (Foo a b) = (\b\' -> Foo a b\') \<$\> f b --- y _ c\@(Bar _) = pure c --- @ --- --- @ --- 'makeLenses' = 'makeLensesWith' 'lensRules' --- @ -makeLenses :: Name -> Q [Dec] -makeLenses = makeLensesWith lensRules - --- | Make lenses and traversals for a type, and create a class when the --- type has no arguments. --- --- /e.g./ --- --- @ --- data Foo = Foo { _fooX, _fooY :: 'Int' } --- 'makeClassy' ''Foo --- @ --- --- will create --- --- @ --- class HasFoo t where --- foo :: 'Control.Lens.Type.Simple' 'Lens' t Foo --- instance HasFoo Foo where foo = 'id' --- fooX, fooY :: HasFoo t => 'Control.Lens.Type.Simple' 'Lens' t 'Int' --- @ --- --- @ --- 'makeClassy' = 'makeLensesWith' 'classyRules' --- @ -makeClassy :: Name -> Q [Dec] -makeClassy = makeLensesWith classyRules - --- | Make lenses and traversals for a type, and create a class when the type --- has no arguments. Works the same as 'makeClassy' except that (a) it --- expects that record field names do not begin with an underscore, (b) all --- record fields are made into lenses, and (c) the resulting lens is prefixed --- with an underscore. -makeClassy_ :: Name -> Q [Dec] -makeClassy_ = makeLensesWith classyRules_ - --- | Make a top level isomorphism injecting /into/ the type. --- --- The supplied name is required to be for a type with a single constructor --- that has a single argument. --- --- /e.g./ --- --- @ --- newtype 'List' a = 'List' [a] --- 'makeIso' ''List --- @ --- --- will create --- --- @ --- 'list' :: 'Iso' [a] [b] ('List' a) ('List' b) --- @ --- --- @ --- 'makeIso' = 'makeLensesWith' 'isoRules' --- @ -makeIso :: Name -> Q [Dec] -makeIso = makeLensesWith isoRules - --- | Derive lenses and traversals, specifying explicit pairings --- of @(fieldName, lensName)@. --- --- If you map multiple names to the same label, and it is present in the same --- constructor then this will generate a 'Traversal'. --- --- /e.g./ --- --- @ --- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo --- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar --- @ -makeLensesFor :: [(String, String)] -> Name -> Q [Dec] -makeLensesFor fields = makeLensesWith $ 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 -> Q [Dec] -makeClassyFor clsName funName fields = makeLensesWith $ - classyRulesFor (const $ Just (clsName, funName)) fields - --- | Build lenses with a custom configuration. -makeLensesWith :: LensRules -> Name -> Q [Dec] -makeLensesWith cfg nm = do - inf <- reify nm - case inf of - TyConI decl -> makeLensesForDec cfg decl - _ -> fail "makeLensesWith: Expected the name of a data type or newtype" - --- | Generate a 'Prism' for each constructor of a data type. --- --- /e.g./ --- --- @ --- data FooBarBaz a --- = Foo Int --- | Bar a --- | Baz Int Char --- makePrisms ''FooBarBaz --- @ --- --- will create --- --- @ --- _Foo :: Prism' (FooBarBaz a) Int --- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b --- _Baz :: Prism' (FooBarBaz a) (Int, Char) --- @ -makePrisms :: Name -> Q [Dec] -makePrisms nm = do - inf <- reify nm - case inf of - TyConI decl -> makePrismsForDec decl - _ -> fail "makePrisms: Expected the name of a data type or newtype" - --- | Make lenses for all records in the given declaration quote. All record --- syntax in the input will be stripped off. --- --- /e.g./ --- --- @ --- declareLenses [d| --- data Foo = Foo { fooX, fooY :: 'Int' } --- deriving 'Show' --- |] --- @ --- --- will create --- --- @ --- data Foo = Foo 'Int' 'Int' deriving 'Show' --- fooX, fooY :: 'Lens'' Foo Int --- @ --- --- @ declareLenses = 'declareLensesWith' ('lensRules' '&' 'lensField' '.~' 'Just') @ -declareLenses :: Q [Dec] -> Q [Dec] -declareLenses = declareLensesWith (lensRules & lensField .~ Just) - --- | Similar to 'makeLensesFor', but takes a declaration quote. -declareLensesFor :: [(String, String)] -> Q [Dec] -> Q [Dec] -declareLensesFor fields = declareLensesWith $ - lensRulesFor fields & lensField .~ Just - --- | For each record in the declaration quote, make lenses and traversals for --- it, and create a class when the type has no arguments. All record syntax --- in the input will be stripped off. --- --- /e.g./ --- --- @ --- declareClassy [d| --- data Foo = Foo { fooX, fooY :: 'Int' } --- deriving 'Show' --- |] --- @ --- --- will create --- --- @ --- data Foo = Foo 'Int' 'Int' deriving 'Show' --- class HasFoo t where --- foo :: 'Lens'' t Foo --- instance HasFoo Foo where foo = 'id' --- fooX, fooY :: HasFoo t => 'Lens'' t 'Int' --- @ --- --- @ declareClassy = 'declareLensesWith' ('classyRules' '&' 'lensField' '.~' 'Just') @ -declareClassy :: Q [Dec] -> Q [Dec] -declareClassy = declareLensesWith (classyRules & lensField .~ Just) - --- | Similar to 'makeClassyFor', but takes a declaration quote. -declareClassyFor :: [(String, (String, String))] -> [(String, String)] -> Q [Dec] -> Q [Dec] -declareClassyFor classes fields = declareLensesWith $ - classyRulesFor (`Prelude.lookup`classes) fields & lensField .~ Just - --- | For each datatype declaration, make a top level isomorphism injecting --- /into/ the type. The types are required to be for a type with a single --- constructor that has a single argument. --- --- All record syntax in the input will be stripped off. --- --- /e.g./ --- --- @ --- declareIso [d| --- newtype WrappedInt = Wrap { unrwap :: 'Int' } --- newtype 'List' a = 'List' [a] --- |] --- @ --- --- will create --- --- @ --- newtype WrappedList = Wrap 'Int' --- newtype List a = List [a] --- 'wrap' :: 'Iso'' Int WrappedInt --- 'unwrap' :: 'Iso'' WrappedInt Int --- 'list' :: 'Iso' [a] [b] ('List' a) ('List' b) --- @ --- --- @ declareIso = 'declareLensesWith' ('isoRules' '&' 'lensField' '.~' 'Just') @ -declareIso :: Q [Dec] -> Q [Dec] -declareIso = declareLensesWith $ isoRules & lensField .~ Just - --- | Generate a 'Prism' for each constructor of each data type. --- --- /e.g./ --- --- @ --- declarePrisms [d| --- data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp } --- |] --- @ --- --- will create --- --- @ --- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp } --- _Lit :: 'Prism'' Exp Int --- _Var :: 'Prism'' Exp String --- _Lambda :: 'Prism'' Exp (String, Exp) --- @ -declarePrisms :: Q [Dec] -> Q [Dec] -declarePrisms = declareWith $ \dec -> do - emit =<< Trans.lift (makePrismsForDec dec) - return dec - --- | Build 'Wrapped' instance for each newtype. -declareWrapped :: Q [Dec] -> Q [Dec] -declareWrapped = declareWith $ \dec -> do - maybeDecs <- Trans.lift (makeWrappedForDec dec) - forM_ maybeDecs emit - return dec - --- | @ declareFields = 'declareFieldsWith' 'defaultFieldRules' @ -declareFields :: Q [Dec] -> Q [Dec] -declareFields = declareFieldsWith defaultFieldRules - --- | Declare lenses for each records in the given declarations, using the --- specified 'LensRules'. Any record syntax in the input will be stripped --- off. -declareLensesWith :: LensRules -> Q [Dec] -> Q [Dec] -declareLensesWith rules = declareWith $ \dec -> do - emit =<< Trans.lift (makeLensesForDec rules dec) - return $ stripFields dec - --- | Declare fields for each records in the given declarations, using the --- specified 'FieldRules'. Any record syntax in the input will be stripped --- off. -declareFieldsWith :: FieldRules -> Q [Dec] -> Q [Dec] -declareFieldsWith rules = declareWith $ \dec -> do - emit =<< Trans.lift (makeFieldsForDec rules dec) - return $ stripFields dec - ------------------------------------------------------------------------------ --- Internal TH Implementation ------------------------------------------------------------------------------ - --- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to --- @DataInstD@s. -deNewtype :: Dec -> Dec -deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d -deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d -deNewtype d = d - -makePrismsForDec :: Dec -> Q [Dec] -makePrismsForDec decl = case makeDataDecl decl of - Just dataDecl -> makePrismsForCons dataDecl - _ -> fail "makePrisms: Unsupported data type" - -makePrismsForCons :: DataDecl -> Q [Dec] -makePrismsForCons dataDecl@(DataDecl _ _ _ _ [_]) = case constructors dataDecl of - -- Iso promotion via tuples - [NormalC dataConName xs] -> - makeIsoLenses rules dataDecl dataConName Nothing $ map (view _2) xs - [RecC dataConName xs] -> - makeIsoLenses rules dataDecl dataConName Nothing $ map (view _3) xs - _ -> - fail "makePrismsForCons: A single-constructor data type is required" - where - rules = isoRules & lensIso .~ (Just . ('_':)) - & backwardIso .~ False - -makePrismsForCons dataDecl = - concat <$> mapM (makePrismOrReviewForCon dataDecl canModifyTypeVar ) (constructors dataDecl) - where - conTypeVars = map (Set.fromList . toListOf typeVars) (constructors dataDecl) - canModifyTypeVar = (`Set.member` typeVarsOnlyInOneCon) . view name - typeVarsOnlyInOneCon = Set.fromList . concat . filter (\xs -> length xs == 1) . List.group . List.sort $ conTypeVars >>= toList - -onlyBuildReview :: Con -> Bool -onlyBuildReview ForallC{} = True -onlyBuildReview _ = False - -makePrismOrReviewForCon :: DataDecl -> (TyVarBndr -> Bool) -> Con -> Q [Dec] -makePrismOrReviewForCon dataDecl canModifyTypeVar con - | onlyBuildReview con = makeReviewForCon dataDecl con - | otherwise = makePrismForCon dataDecl canModifyTypeVar con - -makeReviewForCon :: DataDecl -> Con -> Q [Dec] -makeReviewForCon dataDecl con = do - let functionName = mkName ('_': nameBase dataConName) - (dataConName, fieldTypes) = ctrNameAndFieldTypes con - - sName <- newName "s" - aName <- newName "a" - fieldNames <- replicateM (length fieldTypes) (newName "x") - - -- Compute the type: Constructor Constraints => Review s (Type x y z) a fieldTypes - let s = varT sName - t = return (fullType dataDecl (map (VarT . view name) (dataParameters dataDecl))) - a = varT aName - b = toTupleT (map return fieldTypes) - - (conTyVars, conCxt) = case con of ForallC x y _ -> (x,y) - _ -> ([],[]) - - functionType = forallT (map PlainTV [sName, aName] ++ conTyVars ++ dataParameters dataDecl) - (return conCxt) - (conT ''Review `appsT` [s,t,a,b]) - - -- Compute expression: unto (\(fields) -> Con fields) - let pat = toTupleP (map varP fieldNames) - lam = lam1E pat (conE dataConName `appsE1` map varE fieldNames) - body = varE 'unto `appE` lam - - Prelude.sequence - [ sigD functionName functionType - , funD functionName [clause [] (normalB body) []] - ] - -makePrismForCon :: DataDecl -> (TyVarBndr -> Bool) -> Con -> Q [Dec] -makePrismForCon dataDecl canModifyTypeVar con = do - remitterName <- newName "remitter" - reviewerName <- newName "reviewer" - xName <- newName "x" - let resName = mkName $ '_': nameBase dataConName - varNames <- for [0..length fieldTypes -1] $ \i -> newName ('x' : show i) - let args = dataParameters dataDecl - altArgsList <- forM (view name <$> filter isAltArg args) $ \arg -> - (,) arg <$> newName (nameBase arg) - let altArgs = Map.fromList altArgsList - hitClause = - clause [conP dataConName (fmap varP varNames)] - (normalB $ appE (conE 'Right) $ toTupleE $ varE <$> varNames) [] - otherCons = filter (/= con) (constructors dataDecl) - missClauses - | List.null otherCons = [] - | Map.null altArgs = [clause [varP xName] (normalB (appE (conE 'Left) (varE xName))) []] - | otherwise = reviewerIdClause <$> otherCons - Prelude.sequence [ - sigD resName . forallT - (args ++ (PlainTV <$> Map.elems altArgs)) - (return $ List.nub (dataContext dataDecl ++ substTypeVars altArgs (dataContext dataDecl))) $ - if List.null altArgsList then - conT ''Prism' `appsT` - [ return $ fullType dataDecl $ VarT . view name <$> args - , toTupleT $ pure <$> fieldTypes - ] - else - conT ''Prism `appsT` - [ return $ fullType dataDecl $ VarT . view name <$> args - , return $ fullType dataDecl $ VarT . view name <$> substTypeVars altArgs args - , toTupleT $ pure <$> fieldTypes - , toTupleT $ pure <$> substTypeVars altArgs fieldTypes - ] - , funD resName - [ clause [] - (normalB (appsE [varE 'prism, varE remitterName, varE reviewerName])) - [ funD remitterName - [ clause [toTupleP (varP <$> varNames)] (normalB (conE dataConName `appsE1` fmap varE varNames)) [] ] - , funD reviewerName $ hitClause : missClauses - ] - ] - ] - where - (dataConName, fieldTypes) = ctrNameAndFieldTypes con - conArgs = setOf typeVars fieldTypes - isAltArg arg = canModifyTypeVar arg && conArgs^.contains(arg^.name) - -ctrNameAndFieldTypes :: Con -> (Name, [Type]) -ctrNameAndFieldTypes (NormalC n ts) = (n, snd <$> ts) -ctrNameAndFieldTypes (RecC n ts) = (n, view _3 <$> ts) -ctrNameAndFieldTypes (InfixC l n r) = (n, [snd l, snd r]) -ctrNameAndFieldTypes (ForallC _ _ c) = ctrNameAndFieldTypes c - --- When a 'Prism' can change type variables it needs to pattern match on all --- other data constructors and rebuild the data so it will have the new type. -reviewerIdClause :: Con -> ClauseQ -reviewerIdClause con = do - let (dataConName, fieldTypes) = ctrNameAndFieldTypes con - varNames <- for [0 .. length fieldTypes - 1] $ \i -> - newName ('x' : show i) - clause [conP dataConName (fmap varP varNames)] - (normalB (appE (conE 'Left) (conE dataConName `appsE1` fmap varE varNames))) - [] - --- | 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)) - --- i.e. AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Base.String) --- --> (\(x, y) -> Rect x y) -makeIsoFrom :: Type -> Name -> Q ([Name], Exp) -makeIsoFrom ty conName = lam <$> deCom ty - where - lam (ns, e) = (ns, LamE [TupP (map VarP ns)] e) - deCom (TupleT _) = return ([], ConE conName) - deCom (AppT l _) = do - (ln, l') <- deCom l - x <- newName "x" - return (ln ++ [x], AppE l' (VarE x)) - deCom t = fail $ "unable to create isomorphism for: " ++ show t - --- i.e. AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Base.String) --- --> (\(Rect x y) -> (x, y)) -makeIsoTo :: [Name] -> Name -> ExpQ -makeIsoTo ns conName = lamE [conP conName (map varP ns)] - $ tupE $ map varE ns - -makeIsoBody :: Name -> Exp -> Exp -> DecQ -makeIsoBody lensName f t = funD lensName [clause [] (normalB body) []] where - body = appsE [ varE 'iso - , return f - , return t - ] - -makeLensBody :: Name -> Exp -> Exp -> DecQ -makeLensBody lensName i o = do - f <- newName "f" - a <- newName "a" - funD lensName [clause [] (normalB ( - lamE [varP f, varP a] $ - appsE [ varE 'fmap - , return o - , varE f `appE` (return i `appE` varE a) - ])) []] - -plain :: TyVarBndr -> TyVarBndr -plain (KindedTV t _) = PlainTV t -plain (PlainTV t) = PlainTV t - -apps :: Type -> [Type] -> Type -apps = Prelude.foldl AppT - -makeLensesForDec :: LensRules -> Dec -> Q [Dec] -makeLensesForDec cfg decl = case makeDataDecl decl of - Just dataDecl -> makeLensesForCons cfg dataDecl - Nothing -> fail "makeLensesWith: Unsupported data type" - -makeLensesForCons :: LensRules -> DataDecl -> Q [Dec] -makeLensesForCons cfg dataDecl = case constructors dataDecl of - [NormalC dataConName [( _,ty)]] - | cfg^.handleSingletons -> - makeIsoLenses cfg dataDecl dataConName Nothing [ty] - [RecC dataConName [(fld,_,ty)]] - | cfg^.handleSingletons -> - makeIsoLenses cfg dataDecl dataConName (Just fld) [ty] - _ | cfg^.singletonRequired -> - fail "makeLensesWith: A single-constructor single-argument data type is required" - | otherwise -> - makeFieldLenses cfg dataDecl - -makeDataDecl :: Dec -> Maybe DataDecl -makeDataDecl dec = case deNewtype dec of - DataD ctx tyName args cons _ -> Just DataDecl - { dataContext = ctx - , tyConName = Just tyName - , dataParameters = args - , fullType = apps $ ConT tyName - , constructors = cons - } - DataInstD ctx familyName args cons _ -> Just DataDecl - { dataContext = ctx - , tyConName = Nothing - , dataParameters = map PlainTV vars - , fullType = \tys -> apps (ConT familyName) $ - substType (Map.fromList $ zip vars tys) args - , constructors = cons - } - where - -- The list of "type parameters" to a data family instance is not - -- explicitly specified in the source. Here we define it to be - -- the set of distinct type variables that appear in the LHS. e.g. - -- - -- data instance F a Int (Maybe (a, b)) = G - -- - -- has 2 type parameters: a and b. - vars = toList $ setOf typeVars args - _ -> Nothing - --- | A data, newtype, data instance or newtype instance declaration. -data DataDecl = DataDecl - { dataContext :: Cxt -- ^ Datatype context. - , tyConName :: Maybe Name - -- ^ Type constructor name, or Nothing for a data family instance. - , dataParameters :: [TyVarBndr] -- ^ List of type parameters - , fullType :: [Type] -> Type - -- ^ Create a concrete record type given a substitution to - -- 'detaParameters'. - , constructors :: [Con] -- ^ Constructors - -- , derivings :: [Name] -- currently not needed - } - -makeIsoLenses :: LensRules - -> DataDecl - -> Name - -> Maybe Name - -> [Type] - -> Q [Dec] -makeIsoLenses cfg dataDecl dataConName maybeFieldName partTy = do - let tyArgs = map plain (dataParameters dataDecl) - m <- freshMap $ setOf typeVars tyArgs - let aty = List.foldl' AppT (TupleT $ length partTy) partTy - bty = substTypeVars m aty - sty = fullType dataDecl $ map (VarT . view name) tyArgs - tty = substTypeVars m sty - quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) - (dataContext dataDecl ++ substTypeVars m (dataContext dataDecl)) - maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName) - lensOnly = not $ cfg^.singletonIso - isoCon | lensOnly = ConT ''Lens - | otherwise = ConT ''Iso - isoCon' | lensOnly = ConT ''Lens' - | otherwise = ConT ''Iso' - makeBody | lensOnly = makeLensBody - | otherwise = makeIsoBody - isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do - let backward = cfg^.backwardIso - let decl = SigD isoName $ quantified $ - case (cfg^.simpleLenses || Map.null m, backward) of - (True , False) -> isoCon' `apps` [sty,aty] - (False, False) -> isoCon `apps` [sty,tty,aty,bty] - (True , True ) -> isoCon' `apps` [aty,sty] - (False, True ) -> isoCon `apps` [aty,bty,sty,tty] - (ns, f) <- makeIsoFrom aty dataConName - t <- makeIsoTo ns dataConName - body <- if backward - then makeBody isoName f t - else makeBody isoName t f -#ifndef INLINING - return $ if cfg^.generateSignatures then [decl, body] else [body] -#else - inlining <- inlinePragma isoName - return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining] -#endif - accessorDecls <- case mkName <$> (maybeFieldName >>= view lensField cfg . nameBase) of - jfn@(Just lensName) - | (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do - let decl = SigD lensName $ quantified $ - if cfg^.simpleLenses || Map.null m - then isoCon' `apps` [sty,aty] - else isoCon `apps` [sty,tty,aty,bty] - (ns, f) <- makeIsoFrom aty dataConName - t <- makeIsoTo ns dataConName - body <- makeBody lensName t f -#ifndef INLINING - return $ if cfg^.generateSignatures then [decl, body] else [body] -#else - inlining <- inlinePragma lensName - return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining] -#endif - _ -> return [] - return $ isoDecls ++ accessorDecls - -makeFieldGetterBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec -makeFieldGetterBody isFold lensName conList maybeMethodName - = case maybeMethodName of - Just methodName -> do - go <- newName "go" - let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go) - funD lensName [ clause [] (normalB expr) [funD go clauses] ] - Nothing -> funD lensName clauses - where - clauses = map buildClause conList - - buildClause (con, fields) | isRecord con = do - f <- newName "_f" - vars <- for (con^..conNamedFields._1) $ \fld -> - if fld `List.elem` fields - then Just <$> newName ('_':(nameBase fld++"")) - else return Nothing - let cpats = maybe wildP varP <$> vars -- Deconstruction - fvals = map (appE (varE f) . varE) (catMaybes vars) -- Functor applications - conName = con^.name - - fpat - | List.null fvals = wildP - | otherwise = varP f - - expr - | not isFold && length fields /= 1 - = appE (varE 'error) . litE . stringL - $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields) - | List.null fields - = [| coerce (pure ()) |] - | List.null fvals = [| coerce (pure ()) |] - | otherwise - = let add x y = [| $x *> $y |] - in [| coerce $(List.foldl1 add fvals) |] - clause [fpat, conP conName cpats] (normalB expr) [] - - -- Non-record are never the target of a generated field lens body - buildClause (con, _fields) = - -- clause: _ c@Con{} = expr - -- expr: pure c - clause [wildP, recP (con^.name) []] (normalB [| coerce (pure ()) |]) [] - -isRecord :: Con -> Bool -isRecord RecC{} = True -isRecord NormalC{} = False -isRecord InfixC{} = False -isRecord (ForallC _ _ c) = isRecord c - -makeFieldLensBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec -makeFieldLensBody isTraversal lensName conList maybeMethodName = case maybeMethodName of - Just methodName -> do - go <- newName "go" - let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go) - funD lensName [ clause [] (normalB expr) [funD go clauses] ] - Nothing -> funD lensName clauses - where - clauses = map buildClause conList - - buildClause (con, fields) | isRecord con = do - f <- newName "_f" - vars <- for (con^..conNamedFields._1) $ \fld -> - if fld `List.elem` fields - then Left <$> ((,) <$> newName ('_':(nameBase fld++"'")) <*> newName ('_':nameBase fld)) - else Right <$> newName ('_':nameBase fld) - let cpats = map (varP . either fst id) vars -- Deconstruction - cvals = map (varE . either snd id) vars -- Reconstruction - fpats = map (varP . snd) $ lefts vars -- Lambda patterns - fvals = map (appE (varE f) . varE . fst) $ lefts vars -- Functor applications - conName = con^.name - recon = conE conName `appsE1` cvals - - fpat - | List.null fields = wildP - | otherwise = varP f - expr - | not isTraversal && length fields /= 1 - = appE (varE 'error) . litE . stringL - $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields) - | List.null fields - = appE (varE 'pure) recon - | otherwise - = let step Nothing r = Just $ infixE (Just $ lamE fpats recon) (varE '(<$>)) (Just r) - step (Just l) r = Just $ infixE (Just l) (varE '(<*>)) (Just r) - in fromJust $ List.foldl step Nothing fvals - -- = infixE (Just $ lamE fpats recon) (varE '(<$>)) $ Just $ List.foldl1 (\l r -> infixE (Just l) (varE '(<*>)) (Just r)) fvals - clause [fpat, conP conName cpats] (normalB expr) [] - - -- Non-record are never the target of a generated field lens body - buildClause (con, _fields) = do - let fieldCount = lengthOf conFields con - vars <- replicateM fieldCount (newName "x") - let conName = con^.name - expr - | isTraversal = [| pure $(conE conName `appsE1` map varE vars) |] -- We must rebuild the value to support type changing - | otherwise = [| error errorMsg |] - where errorMsg = show lensName ++ ": non-record constructors require traversals to be generated" - - -- clause: _ c@Con{} = expr - -- expr: pure c - clause [wildP, conP conName (map varP vars)] (normalB expr) [] - -makeFieldLenses :: LensRules - -> DataDecl - -> Q [Dec] -makeFieldLenses cfg dataDecl = do - let tyArgs = map plain $ dataParameters dataDecl - maybeLensClass = view lensClass cfg . nameBase =<< tyConName dataDecl - maybeClassName = fmap (^._1.to mkName) maybeLensClass - cons = constructors dataDecl - t <- newName "t" - a <- newName "a" - - --TODO: there's probably a more efficient way to do this. - lensFields <- map (\xs -> (fst $ head xs, map snd xs)) - . groupBy ((==) `on` fst) . sortBy (comparing fst) - . concat - <$> mapM (getLensFields $ view lensField cfg) cons - - -- varMultiSet knows how many usages of the type variables there are. - let varMultiSet = List.concatMap (toListOf (conFields._2.typeVars)) cons - varSet = Set.fromList $ map (view name) tyArgs - - bodies <- for lensFields $ \(lensName, fields) -> do - let fieldTypes = map (view _3) fields - -- All of the polymorphic variables not involved in these fields - otherVars = varMultiSet List.\\ fieldTypes^..typeVars - -- New type variable binders, and the type to represent the selected fields - (tyArgs', cty) <- unifyTypes tyArgs fieldTypes - -- Map for the polymorphic variables that are only involved in these fields, to new names for them. - m <- freshMap . Set.difference varSet $ Set.fromList otherVars - let aty | isJust maybeClassName = VarT t - | otherwise = fullType dataDecl $ map (VarT . view name) tyArgs' - bty = substTypeVars m aty - dty = substTypeVars m cty - - s = setOf folded m - relevantBndr b = s^.contains (b^.name) - relevantCtx = not . Set.null . Set.intersection s . setOf typeVars - tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs') - ctx = dataContext dataDecl - ps = filter relevantCtx (substTypeVars m ctx) - qs = case maybeClassName of -#if MIN_VERSION_template_haskell(2,10,0) - Just n | not (cfg^.createClass) -> AppT (ConT n) (VarT t) : (ctx ++ ps) -#else - Just n | not (cfg^.createClass) -> ClassP n [VarT t] : (ctx ++ ps) -#endif - | otherwise -> ps - _ -> ctx ++ ps - tvs' = case maybeClassName of - Just _ | not (cfg^.createClass) -> PlainTV t : tvs - | otherwise -> [] - _ -> tvs - - --TODO: Better way to write this? - fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields - conList = map (\c -> (c, Map.findWithDefault [] (view name c) fieldMap)) cons - maybeMethodName = fmap (mkName . view _2) maybeLensClass - - isTraversal <- do - let notSingular = filter ((/= 1) . length . snd) conList - showCon (c, fs) = pprint (c^.name) ++ " { " ++ intercalate ", " (map pprint fs) ++ " }" - case (cfg^.buildTraversals, cfg^.partialLenses) of - (True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses." - (False, True) -> return False - (True, False) | List.null notSingular -> return False - | otherwise -> return True - (False, False) | List.null notSingular -> return False - | otherwise -> fail . unlines $ - [ "Cannot use 'makeLensesWith' with constructors that don't map just one field" - , "to a lens, without using either the buildTraversals or partialLenses flags." - , if length conList == 1 - then "The following constructor failed this criterion for the " ++ pprint lensName ++ " lens:" - else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:" - ] ++ map showCon conList - - let decl = SigD lensName - $ case cty of - ForallT innerTys innerCxt cty' -> - ForallT (tvs'++innerTys) (qs++innerCxt) - $ apps (ConT (if isTraversal then ''Fold else ''Getter)) [aty,cty'] - _ -> - ForallT tvs' qs - $ if aty == bty && cty == dty || cfg^.simpleLenses || isJust maybeClassName - then apps (ConT (if isTraversal then ''Traversal' else ''Lens')) [aty,cty] - else apps (ConT (if isTraversal then ''Traversal else ''Lens)) [aty,bty,cty,dty] - - body <- case cty of - ForallT {} -> makeFieldGetterBody isTraversal lensName conList maybeMethodName - _ -> makeFieldLensBody isTraversal lensName conList maybeMethodName -#ifndef INLINING - return $ if cfg^.generateSignatures then [decl, body] else [body] -#else - inlining <- inlinePragma lensName - return $ if cfg^.generateSignatures then [decl, body, inlining] else [body, inlining] -#endif - let defs = Prelude.concat bodies - case maybeLensClass of - Nothing -> return defs - Just (clsNameString, methodNameString) -> do - let clsName = mkName clsNameString - methodName = mkName methodNameString - varArgs = varT . view name <$> tyArgs - appliedCon = fullType dataDecl <$> sequenceA varArgs - Prelude.sequence $ - filter (\_ -> cfg^.createClass) [ - classD (return []) clsName (PlainTV t : tyArgs) (if List.null tyArgs then [] else [FunDep [t] (view name <$> tyArgs)]) ( - sigD methodName (appsT (conT ''Lens') [varT t, appliedCon]) : - map return defs)] - ++ filter (\_ -> cfg^.createInstance) [ - instanceD (return []) ((conT clsName `appT` appliedCon) `appsT` varArgs) [ - funD methodName [clause [varP a] (normalB (varE a)) []] -#ifdef INLINING - , inlinePragma methodName -#endif - ]] - ++ filter (\_ -> not $ cfg^.createClass) (map return defs) - --- | Gets @[(lens name, (constructor name, field name, type))]@ from a record constructor. -getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))] -getLensFields f (RecC cn fs) - = return . catMaybes - $ fs <&> \(fn,_,t) -> f (nameBase fn) <&> \ln -> (mkName ln, (cn,fn,t)) -getLensFields f (ForallC tvs cxts con) = fmap (filter p) (getLensFields f con) - where - -- Only select fields which do not mention existentially - -- quantified type variables or variables mentioned in internal class constraints - prohibitedTypes = tvs^..typeVars ++ cxts^..typeVars - p field = not (any (\t -> elemOf (_2._3.typeVars) t field) prohibitedTypes) - -getLensFields _ _ - = return [] - --- TODO: properly fill this out --- --- Ideally this would unify the different field types, and figure out which polymorphic variables --- need to be the same. For now it just leaves them the same and yields the first type. --- (This leaves us open to inscrutable compile errors in the generated code) -unifyTypes :: [TyVarBndr] -> [Type] -> Q ([TyVarBndr], Type) -unifyTypes tvs tys = return (tvs, head tys) - --- | Build 'Wrapped' instance for a given newtype -makeWrapped :: Name -> DecsQ -makeWrapped nm = do - inf <- reify nm - case inf of - TyConI decl -> do - maybeDecs <- makeWrappedForDec decl - maybe (fail "makeWrapped: Unsupported data type") return maybeDecs - _ -> fail "makeWrapped: Expected the name of a newtype or datatype" - -makeWrappedForDec :: Dec -> Q (Maybe [Dec]) -makeWrappedForDec decl = case makeDataDecl decl of - Just dataDecl | [con] <- constructors dataDecl - , [field] <- toListOf (conFields._2) con - -> do wrapped <- makeWrappedInstance dataDecl con field - rewrapped <- makeRewrappedInstance dataDecl - return (Just [rewrapped, wrapped]) - _ -> return Nothing - -makeRewrappedInstance :: DataDecl -> DecQ -makeRewrappedInstance dataDecl = do - - t <- varT <$> newName "t" - - let typeArgs = map (view name) (dataParameters dataDecl) - - typeArgs' <- do - m <- freshMap (Set.fromList typeArgs) - return (substTypeVars m typeArgs) - - -- Con a b c... - let appliedType = return (fullType dataDecl (map VarT typeArgs)) - - -- Con a' b' c'... - appliedType' = return (fullType dataDecl (map VarT typeArgs')) - - -- Con a' b' c'... ~ t -#if MIN_VERSION_template_haskell(2,10,0) - eq = AppT. AppT EqualityT <$> appliedType' <*> t -#else - eq = equalP appliedType' t -#endif - - -- Rewrapped (Con a b c...) t - klass = conT ''Rewrapped `appsT` [appliedType, t] - - -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t - instanceD (cxt [eq]) klass [] - -makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ -makeWrappedInstance dataDecl con fieldType = do - - let conName = view name con - let typeArgs = toListOf typeVars (dataParameters dataDecl) - - -- Con a b c... - let appliedType = fullType dataDecl (map VarT typeArgs) - - -- type Unwrapped (Con a b c...) = $fieldType - let unwrappedATF = tySynInstD' ''Unwrapped [return appliedType] (return fieldType) - - -- Wrapped (Con a b c...) - let klass = conT ''Wrapped `appT` return appliedType - - -- _Wrapped' = iso (\(Con x) -> x) Con - let wrapFun = conE conName - let unwrapFun = newName "x" >>= \x -> lam1E (conP conName [varP x]) (varE x) - let isoMethod = funD '_Wrapped' [clause [] (normalB [|iso $unwrapFun $wrapFun|]) []] - - -- instance Wrapped (Con a b c...) where - -- type Unwrapped (Con a b c...) = fieldType - -- _Wrapped' = iso (\(Con x) -> x) Con - instanceD (cxt []) klass [unwrappedATF, isoMethod] - -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse. -instance Applicative Q where - pure = return - (<*>) = ap -#endif - -#ifdef INLINING - -inlinePragma :: Name -> Q Dec -#if MIN_VERSION_template_haskell(2,8,0) - -# ifdef OLD_INLINE_PRAGMAS --- 7.6rc1? -inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase Inline False -# else --- 7.7.20120830 -inlinePragma methodName = pragInlD methodName Inline FunLike AllPhases -# endif - -#else --- GHC <7.6, TH <2.8.0 -inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase True False -#endif - -#endif - -data FieldRules = FieldRules - { _getPrefix :: [String] -> String -> Maybe String - , _rawLensNaming :: String -> String - , _niceLensNaming :: String -> Maybe String - , _classNaming :: String -> Maybe String - } - -data Field = Field - { _fieldName :: Name - , _fieldLensPrefix :: String - , _fieldLensName :: Name - , _fieldClassName :: Name - , _fieldClassLensName :: Name - , _fieldNameType :: Type - } - -overHead :: (a -> a) -> [a] -> [a] -overHead _ [] = [] -overHead f (x:xs) = f x : xs - --- | Field rules for fields in the form @ _prefix_fieldname @ -underscoreFields :: FieldRules -underscoreFields = FieldRules prefix rawLens niceLens classNaming - where - prefix _ ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs) - prefix _ _ = Nothing - rawLens x = x ++ "_lens" - niceLens x = prefix [] x <&> \n -> drop (length n + 2) x - classNaming x = niceLens x <&> ("Has_" ++) - --- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @ --- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. --- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created. -camelCaseFields :: FieldRules -camelCaseFields = FieldRules prefix rawLens niceLens classNaming - where - sepUpper x = case break isUpper x of - (p, s) | List.null p || List.null s -> Nothing - | otherwise -> Just (p,s) - - prefix fields = fmap fst . sepUpper <=< dealWith_ fields - - rawLens x = x ++ "Lens" - niceLens x = overHead toLower . snd <$> sepUpper x - classNaming x = niceLens x <&> \ (n:ns) -> "Has" ++ toUpper n : ns - - dealWith_ :: [String] -> String -> Maybe String - dealWith_ fields field | not $ any (fst . leading_) fields = Just field - | otherwise = if leading then Just trailing else Nothing - where - leading_ ('_':xs) = (True, xs) - leading_ xs = (False, xs) - (leading, trailing) = leading_ field - - - -collectRecords :: [Con] -> [VarStrictType] -collectRecords cons = nubBy varEq allRecordFields - where - varEq (name1,_,_) (name2,_,_) = name1 == name2 - allRecordFields = [ field | RecC _ fields <- cons , field <- fields ] - -verboseLenses :: FieldRules -> Dec -> Q [Dec] -verboseLenses c decl = do - cons <- case deNewtype decl of - DataD _ _ _ cons _ -> return cons - DataInstD _ _ _ cons _ -> return cons - _ -> fail "verboseLenses: Unsupported data type" - let rs = collectRecords cons - if List.null rs - then fail "verboseLenses: Expected the name of a record type" - else flip makeLenses' decl - $ mkFields c rs - & map (\(Field n _ l _ _ _) -> (show n, show l)) - where - makeLenses' fields' = - makeLensesForDec $ lensRules - & lensField .~ (`Prelude.lookup` fields') - & buildTraversals .~ False - & partialLenses .~ True - -mkFields :: FieldRules -> [VarStrictType] -> [Field] -mkFields (FieldRules prefix' raw' nice' clas') rs - = Maybe.mapMaybe namer fieldNamesAndTypes - & List.groupBy (on (==) _fieldLensPrefix) - & (\ gs -> case gs of - x:_ -> x - _ -> []) - where - fieldNamesAndTypes = [(nameBase n, t) | (n,_,t) <- rs] - fieldNames = map fst fieldNamesAndTypes - - namer (field, fieldType) = do - let rawlens = mkName (raw' field) - prefix <- prefix' fieldNames field - nice <- mkName <$> nice' field - clas <- mkName <$> clas' field - return (Field (mkName field) prefix rawlens clas nice fieldType) - -hasClassAndInstance :: FieldRules -> Dec -> Q [Dec] -hasClassAndInstance cfg decl = do - c <- newName "c" - e <- newName "e" - dataDecl <- case makeDataDecl decl of - Just dataDecl -> return dataDecl - _ -> fail "hasClassAndInstance: Unsupported data type" - let rs = collectRecords $ constructors dataDecl - when (List.null rs) $ - fail "hasClassAndInstance: Expected the name of a record type" - fmap concat . forM (mkFields cfg rs) $ \(Field _ _ fullLensName className lensName fieldType) -> do - classHas <- classD - (return []) - className - [ PlainTV c, PlainTV e ] - [ FunDep [c] [e] ] - [ sigD lensName (conT ''Lens' `appsT` [varT c, varT e])] - instanceHas <- instanceD - (return []) - (return $ ConT className `apps` - [fullType dataDecl $ map (VarT . view name) (dataParameters dataDecl) - , fieldType]) - [ -#ifdef INLINING - inlinePragma lensName, -#endif - funD lensName [ clause [] (normalB (varE fullLensName)) [] ] - ] - classAlreadyExists <- isJust `fmap` lookupTypeName (show className) - return (if classAlreadyExists then [instanceHas] else [classHas, instanceHas]) - --- | Make fields with the specified 'FieldRules'. -makeFieldsWith :: FieldRules -> Name -> Q [Dec] -makeFieldsWith c n = do - inf <- reify n - case inf of - TyConI decl -> makeFieldsForDec c decl - _ -> fail "makeFieldsWith: Expected the name of a data type or newtype" - -makeFieldsForDec :: FieldRules -> Dec -> Q [Dec] -makeFieldsForDec cfg decl = liftA2 (++) - (verboseLenses cfg decl) - (hasClassAndInstance cfg decl) - --- | Generate overloaded field accessors. --- --- /e.g/ --- --- @ --- data Foo a = Foo { _fooX :: 'Int', _fooY : a } --- newtype Bar = Bar { _barX :: 'Char' } --- makeFields ''Foo --- makeFields ''Bar --- @ --- --- will create --- --- @ --- _fooXLens :: Lens' (Foo a) Int --- _fooYLens :: Lens (Foo a) (Foo b) a b --- class HasX s a | s -> a where --- x :: Lens' s a --- instance HasX (Foo a) Int where --- x = _fooXLens --- class HasY s a | s -> a where --- y :: Lens' s a --- instance HasY (Foo a) a where --- y = _fooYLens --- _barXLens :: Iso' Bar Char --- instance HasX Bar Char where --- x = _barXLens --- @ --- --- @ --- makeFields = 'makeFieldsWith' 'defaultFieldRules' --- @ -makeFields :: Name -> Q [Dec] -makeFields = makeFieldsWith defaultFieldRules - --- | @ defaultFieldRules = 'camelCaseFields' @ -defaultFieldRules :: FieldRules -defaultFieldRules = camelCaseFields - --- Declaration quote stuff - -declareWith :: (Dec -> Declare Dec) -> Q [Dec] -> Q [Dec] -declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<) - --- | Monad for emitting top-level declarations as a side effect. -type Declare = WriterT (Endo [Dec]) Q - -runDeclare :: Declare [Dec] -> Q [Dec] -runDeclare dec = do - (out, endo) <- runWriterT dec - return $ out ++ appEndo endo [] - -emit :: [Dec] -> Declare () -emit decs = tell $ Endo (decs++) - --- | Traverse each data, newtype, data instance or newtype instance --- declaration. -traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec] -traverseDataAndNewtype f decs = traverse go decs - where - go dec = case dec of - DataD{} -> f dec - NewtypeD{} -> f dec - DataInstD{} -> f dec - NewtypeInstD{} -> f dec - - -- Recurse into instance declarations because they main contain - -- associated data family instances. - InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body - - _ -> pure dec - -stripFields :: Dec -> Dec -stripFields dec = case dec of - DataD ctx tyName tyArgs cons derivings -> - DataD ctx tyName tyArgs (map deRecord cons) derivings - NewtypeD ctx tyName tyArgs con derivings -> - NewtypeD ctx tyName tyArgs (deRecord con) derivings - DataInstD ctx tyName tyArgs cons derivings -> - DataInstD ctx tyName tyArgs (map deRecord cons) derivings - NewtypeInstD ctx tyName tyArgs con derivings -> - NewtypeInstD ctx tyName tyArgs (deRecord con) derivings - _ -> dec - -deRecord :: Con -> Con -deRecord con@NormalC{} = con -deRecord con@InfixC{} = con -deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con -deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields) - where dropFieldName (_, str, typ) = (str, typ) +#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 + , makeFieldsId + -- ** 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 + , classIdFields + -- ** LensRules configuration accessors + , lensField + , FieldNamer + , DefName(..) + , lensClass + , ClassyNamer + , simpleLenses + , createClass + , generateSignatures + , generateUpdateableOptics + , generateLazyPatterns + , generateRecordSyntax + -- ** FieldNamers + , underscoreNoPrefixNamer + , lookingupNamer + , mappingNamer + , camelCaseNamer + , classUnderscoreNoPrefixNamer + , underscoreNamer + , abbreviatedNamer + , classIdNamer + ) 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 for fields whose names are to be used verbatim, with no +-- prefixes, no underscores, no transformations of any kind. +classIdFields :: LensRules +classIdFields = + defaultFieldRules & lensField .~ classIdNamer + +-- | A 'FieldNamer' for 'classIdFields'. +classIdNamer :: FieldNamer +classIdNamer _ _ field = [MethodName (mkName className) (mkName fieldName)] + where + fieldName = nameBase field + className = "Has" ++ overHead toUpper fieldName + +-- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @ +-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. +-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created. +-- +-- 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 + +-- | Generate overloaded field accessors, using exactly the same names as the +-- underlying fields. Intended for use with the @NoFieldSelectors@ and +-- @DuplicateRecordFields@ language extensions. +-- +-- As an example: +-- +-- @ +-- data Foo a = Foo { x :: 'Int', y :: a } +-- newtype Bar = Bar { x :: 'Char' } +-- makeFieldsId ''Foo +-- makeFieldsId ''Bar +-- @ +-- +-- will create classes +-- +-- @ +-- class HasX s a | s -> a where +-- x :: Lens' s a +-- class HasY s a | s -> a where +-- y :: Lens' s a +-- @ +-- +-- together with instances +-- +-- @ +-- instance HasX (Foo a) Int +-- instance HasY (Foo a) a where +-- instance HasX Bar Char where +-- @ +-- +-- @ +-- makeFieldsId = 'makeLensesWith' 'classIdFields' +-- @ +makeFieldsId :: Name -> DecsQ +makeFieldsId = makeFieldOptics classIdFields + +defaultFieldRules :: LensRules +defaultFieldRules = LensRules + { _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) diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs --- a/src/Control/Lens/Traversal.hs +++ b/src/Control/Lens/Traversal.hs @@ -3,21 +3,17 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} - -#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE ConstraintKinds #-} -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(x,y,z) 1 -#endif +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -37,12 +33,12 @@ -- type 'Traversal' s t a b = forall f. 'Applicative' f => (a -> f b) -> s -> f t -- @ -- --- While a 'Traversal' isn't quite a 'Fold', it _can_ be used for --- 'Control.Lens.Getter.Getting' like a 'Fold', because given a --- 'Data.Monoid.Monoid' @m@, we have an 'Applicative' --- for @('Const' m)@. Everything you know how to do with a 'Traversable' --- container, you can with with a 'Traversal', and here we provide --- combinators that generalize the usual 'Traversable' operations. +-- 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 ( @@ -59,6 +55,7 @@ , Traversing1, Traversing1' -- * Traversing and Lensing + , traversal , traverseOf, forOf, sequenceAOf , mapMOf, forMOf, sequenceOf , transposeOf @@ -77,17 +74,18 @@ -- * Parts and Holes , partsOf, partsOf' , unsafePartsOf, unsafePartsOf' - , holesOf + , holesOf, holes1Of , singular, unsafeSingular -- * Common Traversals , Traversable(traverse) , Traversable1(traverse1) - , both + , both, both1 , beside , taking , dropping , failing + , deepOf -- * Indexed Traversals @@ -115,52 +113,75 @@ , imapAccumROf , imapAccumLOf + -- * Reflection + , traverseBy + , traverseByOf + , sequenceBy + , sequenceByOf + -- * Implementation Details , Bazaar(..), Bazaar' , Bazaar1(..), Bazaar1' , loci , iloci + + -- * Fusion + , confusing ) where -import Control.Applicative as Applicative +import Prelude () + import Control.Applicative.Backwards -import Control.Category +import qualified Control.Category as C import Control.Comonad import Control.Lens.Fold -import Control.Lens.Getter (coerced) +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 import Control.Monad.Trans.State.Lazy import Data.Bitraversable -import Data.Functor.Compose +import Data.CallStack +import Data.Functor.Apply +import Data.Functor.Day.Curried +import Data.Functor.Yoneda import Data.Int -import Data.IntMap as IntMap -import Data.Map as Map -import Data.Monoid -import Data.Profunctor -import Data.Profunctor.Rep -import Data.Profunctor.Unsafe +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.Tagged -import Data.Traversable +import Data.Semigroup.Bitraversable import Data.Tuple (swap) -import GHC.Magic (inline) -import Prelude hiding ((.),id) +import GHC.Exts (inline) -- $setup --- >>> :set -XNoOverloadedStrings +-- >>> :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) +-- >>> 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 @@ -208,11 +229,11 @@ -- -- * a 'Traversal' if @f@ is 'Applicative', -- --- * a 'Getter' if @f@ is only 'Gettable', +-- * a 'Getter' if @f@ is only a 'Functor' and 'Data.Functor.Contravariant.Contravariant', -- --- * a 'Lens' if @p@ is only a 'Functor', +-- * a 'Lens' if @f@ is only a 'Functor', -- --- * a 'Fold' if 'f' is 'Gettable' and 'Applicative'. +-- * 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 @@ -227,6 +248,70 @@ -- 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. -- @@ -241,6 +326,7 @@ -- @ -- 'traverseOf' ≡ 'id' -- 'itraverseOf' l ≡ 'traverseOf' l '.' 'Indexed' +-- 'itraverseOf' 'itraversed' ≡ 'itraverse' -- @ -- -- @@ -251,11 +337,12 @@ -- @ -- -- @ --- 'traverseOf' :: 'Functor' f => 'Iso' s t a b -> (a -> f b) -> s -> f t --- 'traverseOf' :: 'Functor' f => 'Lens' s t a b -> (a -> f b) -> s -> f t --- 'traverseOf' :: 'Applicative' f => 'Traversal' s t a b -> (a -> f b) -> s -> f t +-- 'traverseOf' :: '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 :: Over p f s t a b -> p a (f b) -> s -> f t +traverseOf :: LensLike f s t a b -> (a -> f b) -> s -> f t traverseOf = id {-# INLINE traverseOf #-} @@ -284,7 +371,7 @@ -- 'forOf' :: 'Functor' f => 'Lens' s t a b -> s -> (a -> f b) -> f t -- 'forOf' :: 'Applicative' f => 'Traversal' s t a b -> s -> (a -> f b) -> f t -- @ -forOf :: Over p f s t a b -> s -> p a (f b) -> f t +forOf :: LensLike f s t a b -> s -> (a -> f b) -> f t forOf = flip {-# INLINE forOf #-} @@ -324,8 +411,8 @@ -- 'mapMOf' :: 'Monad' m => 'Lens' s t a b -> (a -> m b) -> s -> m t -- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t -- @ -mapMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t -mapMOf l cmd = unwrapMonad #. l (WrapMonad #. cmd) +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'. @@ -344,7 +431,7 @@ -- 'forMOf' :: 'Monad' m => 'Lens' s t a b -> s -> (a -> m b) -> m t -- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t -- @ -forMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> s -> p a (m b) -> m t +forMOf :: LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t forMOf l a cmd = unwrapMonad (l (WrapMonad #. cmd) a) {-# INLINE forMOf #-} @@ -406,7 +493,7 @@ -- @ -- 'mapAccumROf' :: 'LensLike' ('Backwards' ('State' acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ -mapAccumROf :: Conjoined p => Over p (Backwards (State acc)) s t a b -> p acc (a -> (acc, b)) -> acc -> s -> (acc, t) +mapAccumROf :: LensLike (Backwards (State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumROf = mapAccumLOf . backwards {-# INLINE mapAccumROf #-} @@ -429,9 +516,9 @@ -- 'mapAccumLOf' l f acc0 s = 'swap' ('runState' (l (\a -> 'state' (\acc -> 'swap' (f acc a))) s) acc0) -- @ -- -mapAccumLOf :: Conjoined p => Over p (State acc) s t a b -> p acc (a -> (acc, b)) -> acc -> s -> (acc, t) +mapAccumLOf :: 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 = cotabulate $ \wa -> state $ \acc -> swap (corep f (acc <$ wa) (extract wa)) + g a = state $ \acc -> swap (f acc a) -- This would be much cleaner if the argument order for the function was swapped. {-# INLINE mapAccumLOf #-} @@ -481,7 +568,7 @@ {-# INLINE iloci #-} ------------------------------------------------------------------------------- --- Parts and Holes +-- 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. @@ -499,6 +586,9 @@ -- >>> (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'. @@ -574,36 +664,6 @@ (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in unsafeOuts b <$> indexed f (is :: [i]) as) {-# INLINE iunsafePartsOf' #-} --- | The one-level version of 'Control.Lens.Plated.contextsOf'. This extracts a list of the immediate children according to a given 'Traversal' as editable contexts. --- --- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the values, 'Control.Comonad.Store.Class.peek' at what the structure would be like with an edited result, or simply 'extract' the original structure. --- --- @ --- propChildren l x = childrenOf l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x) --- propId l x = 'all' ('==' x) ['extract' w | w <- 'holesOf' l x] --- @ --- --- @ --- 'holesOf' :: 'Iso'' s a -> s -> ['Pretext'' (->) a s] --- 'holesOf' :: 'Lens'' s a -> s -> ['Pretext'' (->) a s] --- 'holesOf' :: 'Traversal'' s a -> s -> ['Pretext'' (->) a s] --- 'holesOf' :: 'IndexedLens'' i s a -> s -> ['Pretext'' ('Indexed' i) a s] --- 'holesOf' :: 'IndexedTraversal'' i s a -> s -> ['Pretext'' ('Indexed' i) a s] --- @ -holesOf :: forall p s t a. Conjoined p => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t] -holesOf l s = unTagged - ( conjoined - (Tagged $ let - f [] _ = [] - f (x:xs) g = Pretext (\xfy -> g . (:xs) <$> xfy x) : f xs (g . (x:)) - in f (ins b) (unsafeOuts b)) - (Tagged $ let - f [] _ = [] - f (wx:xs) g = Pretext (\wxfy -> g . (:Prelude.map extract xs) <$> corep wxfy wx) : f xs (g . (extract wx:)) - in f (pins b) (unsafeOuts b)) - :: Tagged (p a b) [Pretext p a a t] - ) where b = l sell s -{-# INLINE holesOf #-} -- | This converts a 'Traversal' that you \"know\" will target one or more elements to a 'Lens'. It can -- also be used to transform a non-empty 'Fold' into a 'Getter'. @@ -614,8 +674,7 @@ -- >>> [1,2,3] ^. singular _head -- 1 -- --- >>> [] ^. singular _head --- *** Exception: singular: empty traversal +-- >>> Left (ErrorCall "singular: empty traversal") <- try (evaluate ([] ^. singular _head)) :: IO (Either ErrorCall ()) -- -- >>> Left 4 ^. singular _Left -- 4 @@ -623,13 +682,16 @@ -- >>> [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 :: (Conjoined p, Functor f) +singular :: (HasCallStack, Conjoined p, Functor f) => Traversing p f s t a a -> Over p f s t a a singular l = conjoined @@ -637,8 +699,8 @@ (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 . (:Prelude.map extract ws) <$> corep pafb w - [] -> unsafeOuts b . return <$> corep pafb (error "singular: empty traversal")) + (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 @@ -647,13 +709,15 @@ -- 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 :: (Conjoined p, Functor f) +unsafeSingular :: (HasCallStack, Conjoined p, Functor f) => Traversing p f s t a b -> Over p f s t a b unsafeSingular l = conjoined @@ -662,17 +726,17 @@ [] -> 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 <$> corep pafb w + [w] -> unsafeOuts b . return <$> cosieve pafb w [] -> error "unsafeSingular: empty traversal" _ -> error "unsafeSingular: traversing multiple results") {-# INLINE unsafeSingular #-} ------------------------------------------------------------------------------ --- Internal functions used by 'partsOf', 'holesOf', etc. +-- Internal functions used by 'partsOf', etc. ------------------------------------------------------------------------------ ins :: Bizarre (->) w => w a b t -> [a] -ins = toListOf (coerced bazaar) +ins = toListOf (getting bazaar) {-# INLINE ins #-} wins :: (Bizarre p w, Corepresentable p, Comonad (Corep p)) => w a b t -> [a] @@ -683,11 +747,11 @@ pins = getConst #. bazaar (cotabulate $ \ra -> Const [ra]) {-# INLINE pins #-} -parr :: (Profunctor p, Category p) => (a -> b) -> p a b -parr f = lmap f id +parr :: (Profunctor p, C.Category p) => (a -> b) -> p a b +parr f = lmap f C.id {-# INLINE parr #-} -outs :: (Bizarre p w, Category p) => w a a t -> [a] -> t +outs :: (Bizarre p w, C.Category p) => w a a t -> [a] -> t outs = evalState `rmap` bazaar (parr (state . unconsWithDefault)) {-# INLINE outs #-} @@ -701,13 +765,123 @@ 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. +-- 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) @@ -726,6 +900,18 @@ 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. -- -- @ @@ -739,8 +925,6 @@ -- 'beside' :: 'Lens' s t a b -> 'Lens' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Fold' s a -> 'Fold' s' a -> 'Fold' (s,s') a -- 'beside' :: 'Getter' s a -> 'Getter' s' a -> 'Fold' (s,s') a --- 'beside' :: 'Action' m s a -> 'Action' m s' a -> 'MonadicFold' m (s,s') a --- 'beside' :: 'MonadicFold' m s a -> 'MonadicFold' m s' a -> 'MonadicFold' m (s,s') a -- @ -- -- @ @@ -748,8 +932,6 @@ -- 'beside' :: 'IndexedLens' i s t a b -> 'IndexedLens' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b -- 'beside' :: 'IndexedFold' i s a -> 'IndexedFold' i s' a -> 'IndexedFold' i (s,s') a -- 'beside' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s' a -> 'IndexedFold' i (s,s') a --- 'beside' :: 'IndexedAction' i m s a -> 'IndexedAction' i m s' a -> 'IndexedMonadicFold' i m (s,s') a --- 'beside' :: 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s' a -> 'IndexedMonadicFold' i m (s,s') a -- @ -- -- @ @@ -757,8 +939,6 @@ -- 'beside' :: 'IndexPreservingLens' s t a b -> 'IndexPreservingLens' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b -- 'beside' :: 'IndexPreservingFold' s a -> 'IndexPreservingFold' s' a -> 'IndexPreservingFold' (s,s') a -- 'beside' :: 'IndexPreservingGetter' s a -> 'IndexPreservingGetter' s' a -> 'IndexPreservingFold' (s,s') a --- 'beside' :: 'IndexPreservingAction' m s a -> 'IndexPreservingAction' m s' a -> 'IndexPreservingMonadicFold' m (s,s') a --- 'beside' :: 'IndexPreservingMonadicFold' m s a -> 'IndexPreservingMonadicFold' m s' a -> 'IndexPreservingMonadicFold' m (s,s') a -- @ -- -- >>> ("hello",["world","!!!"])^..beside id traverse @@ -767,7 +947,7 @@ => Optical p q f s t a b -> Optical p q f s' t' a b -> Optical p q f (r s s') (r t t') a b -beside l r f = tabulate $ getCompose #. bitraverse (Compose #. rep (l f)) (Compose #. rep (r f)) +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'. @@ -799,7 +979,7 @@ -> 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 (corep pafb) (take n $ pins 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'. @@ -826,7 +1006,7 @@ -- @ dropping :: (Conjoined p, Applicative f) => Int -> Over p (Indexing f) s t a a -> Over p f s t a a dropping n l pafb s = snd $ runIndexing (l paifb s) 0 where - paifb = cotabulate $ \wa -> Indexing $ \i -> let i' = i + 1 in i' `seq` (i', if i < n then pure (extract wa) else corep pafb wa) + 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 #-} ------------------------------------------------------------------------------ @@ -843,11 +1023,11 @@ -- as such, use 'Control.Lens.Lens.cloneLens'. -- -- Note: It is usually better to use 'Control.Lens.Reified.ReifiedTraversal' and --- 'Control.Lens.Reified.reflectTraversal' than to 'cloneTraversal'. The +-- '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 (coerced (cloneTraversal l)) a, set (cloneTraversal l) 10 a) +-- >>> let foo l a = (view (getting (cloneTraversal l)) a, set (cloneTraversal l) 10 a) -- >>> foo both ("hello","world") -- ("helloworld",(10,10)) -- @@ -861,7 +1041,7 @@ -- | Clone a 'Traversal' yielding an 'IndexPreservingTraversal' that passes through -- whatever index it is composed with. cloneIndexPreservingTraversal :: ATraversal s t a b -> IndexPreservingTraversal s t a b -cloneIndexPreservingTraversal l pafb = cotabulate $ \ws -> runBazaar (l sell (extract ws)) $ \a -> corep pafb (a <$ ws) +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. @@ -877,7 +1057,7 @@ -- | Clone a 'Traversal1' yielding an 'IndexPreservingTraversal1' that passes through -- whatever index it is composed with. cloneIndexPreservingTraversal1 :: ATraversal1 s t a b -> IndexPreservingTraversal1 s t a b -cloneIndexPreservingTraversal1 l pafb = cotabulate $ \ws -> runBazaar1 (l sell (extract ws)) $ \a -> corep pafb (a <$ ws) +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. @@ -939,8 +1119,8 @@ -- 'imapMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> (i -> a -> m b) -> s -> m t -- 'imapMOf' :: 'Bind' m => 'IndexedTraversal1' i s t a b -> (i -> a -> m b) -> s -> m t -- @ -imapMOf :: (Indexed i a (WrappedMonad m b) -> s -> WrappedMonad m t) -> (i -> a -> m b) -> s -> m t -imapMOf l = mapMOf l .# Indexed +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, @@ -973,7 +1153,7 @@ -- 'imapAccumROf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ imapAccumROf :: Over (Indexed i) (Backwards (State acc)) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -imapAccumROf l = mapAccumROf l .# Indexed +imapAccumROf = imapAccumLOf . backwards {-# INLINE imapAccumROf #-} -- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IndexedTraversal' with access to the index. @@ -989,7 +1169,8 @@ -- 'imapAccumLOf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ imapAccumLOf :: Over (Indexed i) (State acc) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -imapAccumLOf l = mapAccumLOf l .# Indexed +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 #-} ------------------------------------------------------------------------------ @@ -999,8 +1180,24 @@ -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b traversed = conjoined traverse (indexing traverse) -{-# INLINE traversed #-} +{-# 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) @@ -1032,13 +1229,9 @@ -- | 'IndexedTraversal' of the element with the smallest index. traverseMin :: IndexedTraversal' k (m v) v -instance TraverseMin Int IntMap where +instance TraverseMin Int IntMap.IntMap where traverseMin f m = case IntMap.minViewWithKey m of -#if MIN_VERSION_containers(0,5,0) Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const (Just v)) m -#else - Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const v) m -#endif Nothing -> pure m {-# INLINE traverseMin #-} @@ -1053,13 +1246,9 @@ -- | 'IndexedTraversal' of the element at the largest index. traverseMax :: IndexedTraversal' k (m v) v -instance TraverseMax Int IntMap where +instance TraverseMax Int IntMap.IntMap where traverseMax f m = case IntMap.maxViewWithKey m of -#if MIN_VERSION_containers(0,5,0) Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const (Just v)) m -#else - Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const v) m -#endif Nothing -> pure m {-# INLINE traverseMax #-} @@ -1069,7 +1258,7 @@ Nothing -> pure m {-# INLINE traverseMax #-} --- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or +-- | Traverse the /nth/ 'elementOf' a 'Traversal', 'Lens' or -- 'Iso' if it exists. -- -- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 @@ -1101,7 +1290,7 @@ -- 'element' ≡ 'elementOf' 'traverse' -- @ element :: Traversable t => Int -> IndexedTraversal' Int (t a) a -element = elementOf traverse +element i = elementOf traverse i {-# INLINE element #-} -- | Traverse (or fold) selected elements of a 'Traversal' (or 'Fold') where their ordinal positions match a predicate. @@ -1117,13 +1306,13 @@ elementsOf l p iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, if p i then indexed iafb i a else pure a))) s) 0 {-# INLINE elementsOf #-} --- | Traverse elements of a 'Traversable' container where their ordinal positions matches a predicate. +-- | 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 = elementsOf traverse +elements i = elementsOf traverse i {-# INLINE elements #-} -- | Try to map a function over this 'Traversal', failing if the 'Traversal' has no targets. @@ -1140,10 +1329,10 @@ -- @ -- 'failover' :: Alternative m => Traversal s t a b -> (a -> b) -> s -> m t -- @ -failover :: (Profunctor p, Alternative m) => Over p ((,) Any) s t a b -> p a b -> s -> m t -failover l pafb s = case l ((,) (Any True) `rmap` pafb) s of +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, _) -> Applicative.empty + (Any False, _) -> empty {-# INLINE failover #-} -- | Try to map a function which uses the index over this 'IndexedTraversal', failing if the 'IndexedTraversal' has no targets. @@ -1152,7 +1341,9 @@ -- 'ifailover' :: Alternative m => IndexedTraversal i s t a b -> (i -> a -> b) -> s -> m t -- @ ifailover :: Alternative m => Over (Indexed i) ((,) Any) s t a b -> (i -> a -> b) -> s -> m t -ifailover l f = failover l (Indexed f) +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. @@ -1163,6 +1354,12 @@ -- -- 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 @@ -1192,9 +1389,80 @@ -- 'failing' :: 'IndexedLens' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -- 'failing' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- @ -failing :: (Conjoined p, Applicative f) => Traversing p f s t a b -> Traversing p f s t a b -> Over p f s t a b +failing :: (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 - [] -> runBazaarT (r sell s) pafb - xs -> unsafeOuts b <$> traverse (corep pafb) xs + [] -> 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) diff --git a/src/Control/Lens/Tuple.hs b/src/Control/Lens/Tuple.hs --- a/src/Control/Lens/Tuple.hs +++ b/src/Control/Lens/Tuple.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE EmptyDataDecls #-} @@ -8,16 +9,15 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE PolyKinds #-} +#include "lens-common.h" + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Tuple --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -36,14 +36,30 @@ , 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 Control.Applicative -import Control.Lens.Lens -import Data.Functor.Identity -import Data.Profunctor (dimap) -import Data.Proxy (Proxy (Proxy)) -import GHC.Generics (Generic (..), (:*:) (..), K1 (..), M1 (..), U1 (..)) +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 @@ -79,16 +95,24 @@ -- '_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 -#ifndef HLINT default _1 :: (Generic s, Generic t, GIxed N0 (Rep s) (Rep t) a b) => Lens s t a b _1 = ix proxyN0 {-# INLINE _1 #-} -#endif 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 -- @ @@ -124,6 +148,46 @@ _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. @@ -144,13 +208,21 @@ -- '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 -#ifndef HLINT default _2 :: (Generic s, Generic t, GIxed N1 (Rep s) (Rep t) a b) => Lens s t a b _2 = ix proxyN1 {-# INLINE _2 #-} -#endif +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 -- @ @@ -186,16 +258,55 @@ _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 -#ifndef HLINT default _3 :: (Generic s, Generic t, GIxed N2 (Rep s) (Rep t) a b) => Lens s t a b _3 = ix proxyN2 {-# INLINE _3 #-} -#endif instance Field3 (a,b,c) (a,b,c') c c' where _3 k ~(a,b,c) = k c <&> \c' -> (a,b,c') @@ -225,16 +336,54 @@ _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 -#ifndef HLINT default _4 :: (Generic s, Generic t, GIxed N3 (Rep s) (Rep t) a b) => Lens s t a b _4 = ix proxyN3 {-# INLINE _4 #-} -#endif 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') @@ -260,16 +409,54 @@ _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 -#ifndef HLINT default _5 :: (Generic s, Generic t, GIxed N4 (Rep s) (Rep t) a b) => Lens s t a b _5 = ix proxyN4 {-# INLINE _5 #-} -#endif 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') @@ -291,16 +478,54 @@ _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 -#ifndef HLINT default _6 :: (Generic s, Generic t, GIxed N5 (Rep s) (Rep t) a b) => Lens s t a b _6 = ix proxyN5 {-# INLINE _6 #-} -#endif instance Field6 (a,b,c,d,e,f) (a,b,c,d,e,f') f f' where _6 k ~(a,b,c,d,e,f) = k f <&> \f' -> (a,b,c,d,e,f') @@ -318,16 +543,54 @@ _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 -#ifndef HLINT default _7 :: (Generic s, Generic t, GIxed N6 (Rep s) (Rep t) a b) => Lens s t a b _7 = ix proxyN6 {-# INLINE _7 #-} -#endif instance Field7 (a,b,c,d,e,f,g) (a,b,c,d,e,f,g') g g' where _7 k ~(a,b,c,d,e,f,g) = k g <&> \g' -> (a,b,c,d,e,f,g') @@ -341,16 +604,54 @@ _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 -#ifndef HLINT default _8 :: (Generic s, Generic t, GIxed N7 (Rep s) (Rep t) a b) => Lens s t a b _8 = ix proxyN7 {-# INLINE _8 #-} -#endif instance Field8 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h') h h' where _8 k ~(a,b,c,d,e,f,g,h) = k h <&> \h' -> (a,b,c,d,e,f,g,h') @@ -360,26 +661,512 @@ _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 -#ifndef HLINT default _9 :: (Generic s, Generic t, GIxed N8 (Rep s) (Rep t) a b) => Lens s t a b _9 = ix proxyN8 {-# INLINE _9 #-} -#endif instance Field9 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i') i i' where _9 k ~(a,b,c,d,e,f,g,h,i) = 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 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 @@ -403,14 +1190,12 @@ gix = gix' (Proxy :: Proxy p) {-# INLINE gix #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 -- $gixed-fundeps -- >>> :set -XDeriveGeneric -XFlexibleInstances -XMultiParamTypeClasses -- >>> import GHC.Generics (Generic) -- >>> data Product a b = a :* b deriving Generic -- >>> instance Field1 (Product a b) (Product a' b) a a' -- >>> instance Field2 (Product a b) (Product a b') b b' -#endif class (p ~ GT (GSize s) n, p ~ GT (GSize t) n) @@ -462,6 +1247,16 @@ 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 @@ -498,3 +1293,43 @@ 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 #-} diff --git a/src/Control/Lens/Type.hs b/src/Control/Lens/Type.hs --- a/src/Control/Lens/Type.hs +++ b/src/Control/Lens/Type.hs @@ -5,11 +5,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE Trustworthy #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE PolyKinds #-} +#else +{-# LANGUAGE TypeInType #-} +#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Type --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -25,6 +31,7 @@ Equality, Equality', As , Iso, Iso' , Prism , Prism' + , Review , AReview -- * Lenses, Folds and Traversals , Lens, Lens' , Traversal, Traversal' @@ -32,7 +39,6 @@ , Setter, Setter' , Getter, Fold , Fold1 - , Action, MonadicFold, RelevantMonadicFold -- * Indexed , IndexedLens, IndexedLens' , IndexedTraversal, IndexedTraversal' @@ -40,8 +46,6 @@ , IndexedSetter, IndexedSetter' , IndexedGetter, IndexedFold , IndexedFold1 - , IndexedAction, IndexedMonadicFold - , IndexedRelevantMonadicFold -- * Index-Preserving , IndexPreservingLens, IndexPreservingLens' , IndexPreservingTraversal, IndexPreservingTraversal' @@ -49,8 +53,6 @@ , IndexPreservingSetter, IndexPreservingSetter' , IndexPreservingGetter, IndexPreservingFold , IndexPreservingFold1 - , IndexPreservingAction, IndexPreservingMonadicFold - , IndexPreservingRelevantMonadicFold -- * Common , Simple , LensLike, LensLike' @@ -60,13 +62,14 @@ , Optic, Optic' ) where -import Control.Applicative -import Control.Lens.Internal.Action +import Prelude () + +import Control.Lens.Internal.Prelude import Control.Lens.Internal.Setter import Control.Lens.Internal.Indexed -import Data.Functor.Contravariant +import Data.Bifunctor import Data.Functor.Apply -import Data.Profunctor +import Data.Kind -- $setup -- >>> :set -XNoOverloadedStrings @@ -203,6 +206,11 @@ -- @ 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 @@ -213,6 +221,10 @@ -- 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 -- | @ @@ -223,7 +235,7 @@ type IndexedTraversal1 i s t a b = forall p f. (Indexable i p, Apply f) => p a (f b) -> s -> f t type IndexedTraversal1' i s a = IndexedTraversal1 i s s a a --- | An 'IndexPreservingLens' leaves any index it is composed with alone. +-- | 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) -- | @ @@ -288,7 +300,7 @@ -- @ -- -- @ --- type 'Setter'' = 'Setter'' +-- type 'Setter'' = 'Simple' 'Setter' -- @ type Setter' s a = Setter s s a a @@ -318,6 +330,14 @@ -- | 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) @@ -327,6 +347,22 @@ 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 ------------------------------------------------------------------------------ @@ -334,25 +370,33 @@ -- around with 'Control.Lens.Review.re' to obtain a 'Getter' in the -- opposite direction. -- --- There are two laws that a 'Prism' should satisfy: +-- There are three laws that a 'Prism' should satisfy: -- --- First, if I 'Control.Lens.Review.re' or 'Control.Lens.Prism.review' a value with a 'Prism' and then 'Control.Lens.Fold.preview' or use ('Control.Lens.Fold.^?'), I will get it back: +-- 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.Prism.review' l b) ≡ 'Just' b +-- '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 my @l@ and @a@: +-- 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@: -- --- If @'Control.Lens.Fold.preview' l s ≡ 'Just' a@ then @'Control.Lens.Prism.review' l a ≡ s@ +-- @ +-- 'Control.Lens.Fold.preview' l s ≡ 'Just' a ⟹ 'Control.Lens.Review.review' l a ≡ s +-- @ -- --- These two laws imply that the 'Traversal' laws hold for every 'Prism' and that we 'Data.Traversable.traverse' at most 1 element: +-- 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 a 'Iso' that can be partial in one direction. +-- It may help to think of this as an 'Iso' that can be partial in one direction. -- -- Every 'Prism' is a valid 'Traversal'. -- @@ -420,7 +464,8 @@ -- | A witness that @(a ~ s, b ~ t)@. -- -- Note: Composition with an 'Equality' is index-preserving. -type Equality s t a b = forall p (f :: * -> *). p a (f b) -> p s (f t) +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 @@ -483,53 +528,6 @@ type IndexPreservingFold1 s a = forall p f. (Conjoined p, Contravariant f, Apply f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- --- Actions -------------------------------------------------------------------------------- - --- | An 'Action' is a 'Getter' enriched with access to a 'Monad' for side-effects. --- --- Every 'Getter' can be used as an 'Action'. --- --- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. -type Action m s a = forall f r. Effective m r f => (a -> f a) -> s -> f s - --- | An 'IndexedAction' is an 'IndexedGetter' enriched with access to a 'Monad' for side-effects. --- --- Every 'Getter' can be used as an 'Action'. --- --- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. -type IndexedAction i m s a = forall p f r. (Indexable i p, Effective m r f) => p a (f a) -> s -> f s - --- | An 'IndexPreservingAction' can be used as a 'Action', but when composed with an 'IndexedTraversal', --- 'IndexedFold', or 'IndexedLens' yields an 'IndexedMonadicFold', 'IndexedMonadicFold' or 'IndexedAction' respectively. -type IndexPreservingAction m s a = forall p f r. (Conjoined p, Effective m r f) => p a (f a) -> p s (f s) - -------------------------------------------------------------------------------- --- MonadicFolds -------------------------------------------------------------------------------- - --- | A 'MonadicFold' is a 'Fold' enriched with access to a 'Monad' for side-effects. --- --- Every 'Fold' can be used as a 'MonadicFold', that simply ignores the access to the 'Monad'. --- --- You can compose a 'MonadicFold' with another 'MonadicFold' using ('Prelude..') from the @Prelude@. -type MonadicFold m s a = forall f r. (Effective m r f, Applicative f) => (a -> f a) -> s -> f s -type RelevantMonadicFold m s a = forall f r. (Effective m r f, Apply f) => (a -> f a) -> s -> f s - --- | An 'IndexedMonadicFold' is an 'IndexedFold' enriched with access to a 'Monad' for side-effects. --- --- Every 'IndexedFold' can be used as an 'IndexedMonadicFold', that simply ignores the access to the 'Monad'. --- --- You can compose an 'IndexedMonadicFold' with another 'IndexedMonadicFold' using ('Prelude..') from the @Prelude@. -type IndexedMonadicFold i m s a = forall p f r. (Indexable i p, Effective m r f, Applicative f) => p a (f a) -> s -> f s -type IndexedRelevantMonadicFold i m s a = forall p f r. (Indexable i p, Effective m r f, Apply f) => p a (f a) -> s -> f s - --- | An 'IndexPreservingFold' can be used as a 'Fold', but when composed with an 'IndexedTraversal', --- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold' respectively. -type IndexPreservingMonadicFold m s a = forall p f r. (Conjoined p, Effective m r f, Applicative f) => p a (f a) -> p s (f s) -type IndexPreservingRelevantMonadicFold m s a = forall p f r. (Conjoined p, Effective m r f, Apply f) => p a (f a) -> p s (f s) - -------------------------------------------------------------------------------- -- Simple Overloading ------------------------------------------------------------------------------- @@ -569,12 +567,20 @@ type Optic p f s t a b = p a (f b) -> p s (f t) -- | @ --- type 'Optic'' p q f s a = 'Simple' ('Optic' p q f) s a +-- 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) diff --git a/src/Control/Lens/Unsound.hs b/src/Control/Lens/Unsound.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Unsound.hs @@ -0,0 +1,101 @@ +{-# 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 diff --git a/src/Control/Lens/Wrapped.hs b/src/Control/Lens/Wrapped.hs --- a/src/Control/Lens/Wrapped.hs +++ b/src/Control/Lens/Wrapped.hs @@ -1,27 +1,36 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif +{-# 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-14 Edward Kmett, Michael Sloan +-- 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 'Wrapped' class provides similar functionality as @Control.Newtype@, +-- 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 @@ -56,19 +65,35 @@ -- * Operations , op , ala, alaf + -- * Pattern Synonyms + , pattern Wrapped + , pattern Unwrapped + -- * Generics + , _GWrapped' ) where -import Control.Applicative +#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.Error +import Control.Monad.Trans.Except +import Control.Monad.Trans.Free import Control.Monad.Trans.Identity -import Control.Monad.Trans.List +import Control.Monad.Trans.Iter import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.RWS.Lazy as Lazy @@ -77,49 +102,125 @@ 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.Coproduct import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable -import Data.IntSet as IntSet -import Data.IntMap as IntMap -import Data.HashSet as HashSet -import Data.HashMap.Lazy as HashMap -import Data.Map as Map +import 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.Sequence as Seq hiding (length) -import Data.Set as Set +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 +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif +import qualified Data.Vector.Primitive as Prim +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Unboxed as Unboxed +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 (..)) --- | 'Wrapped' provides isomorphisms to wrap and unwrap newtypes or +-- | t'Wrapped' provides isomorphisms to wrap and unwrap newtypes or -- data types with one constructor. class Wrapped s where - type Unwrapped s :: * + 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 :: *) (t :: *) +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 %~ length & getConst +-- >>> Const "hello" & _Wrapped %~ Prelude.length & getConst -- 5 -- -- @ @@ -172,10 +273,10 @@ _Wrapped' = iso unwrapMonad WrapMonad {-# INLINE _Wrapped' #-} -instance (t ~ WrappedArrow a' b' c') => Rewrapped (WrappedArrow a b c) t -instance Wrapped (WrappedArrow a b c) where - type Unwrapped (WrappedArrow a b c) = a b c - _Wrapped' = iso unwrapArrow WrapArrow +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 @@ -184,6 +285,12 @@ _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 @@ -196,7 +303,7 @@ _Wrapped' = iso getDual Dual {-# INLINE _Wrapped' #-} -instance (t ~ Endo b) => Rewrapped (Endo b) t +instance (t ~ Endo b) => Rewrapped (Endo a) t instance Wrapped (Endo a) where type Unwrapped (Endo a) = a -> a _Wrapped' = iso appEndo Endo @@ -208,18 +315,48 @@ _Wrapped' = iso getFirst First {-# INLINE _Wrapped' #-} -instance (t ~ Last b) => Rewrapped (Last b) t +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 ~ ArrowMonad m' a', ArrowApply m, ArrowApply m') => Rewrapped (ArrowMonad m a) t -instance ArrowApply m => Wrapped (ArrowMonad m a) where +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 @@ -242,10 +379,10 @@ type Unwrapped (ContT r m a) = (a -> m r) -> m r _Wrapped' = iso runContT ContT -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 +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 @@ -260,19 +397,13 @@ _Wrapped' = iso runIdentityT IdentityT {-# INLINE _Wrapped' #-} -instance (t ~ ListT n b) => Rewrapped (ListT m a) t -instance Wrapped (ListT m a) where - type Unwrapped (ListT m a) = m [a] - _Wrapped' = iso runListT ListT - {-# INLINE _Wrapped' #-} - instance (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 r n b) => Rewrapped (ReaderT r m a) t +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 @@ -320,30 +451,134 @@ _Wrapped' = iso Strict.runWriterT Strict.WriterT {-# INLINE _Wrapped' #-} --- * comonad-transformers +#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 ~ Coproduct f' g' a') => Rewrapped (Coproduct f g a) t -instance Wrapped (Coproduct f g a) where - type Unwrapped (Coproduct f g a) = Either (f a) (g a) - _Wrapped' = iso getCoproduct Coproduct +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. +-- | 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. +-- | 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] @@ -352,28 +587,28 @@ -- * containers --- | Use @'wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list. +-- | 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. +-- | 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. +-- | 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. +-- | 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] @@ -386,6 +621,110 @@ _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' #-} + +#if MIN_VERSION_vector(0,13,2) +instance (t ~ Vector.Vector a') => Rewrapped (VectorStrict.Vector a) t +instance Wrapped (VectorStrict.Vector a) where + type Unwrapped (VectorStrict.Vector a) = [a] + _Wrapped' = iso VectorStrict.toList VectorStrict.fromList + {-# INLINE _Wrapped' #-} +#endif + +-- * semigroupoids + +instance (t ~ WrappedApplicative f' a') => Rewrapped (WrappedApplicative f a) t +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 @@ -418,11 +757,13 @@ _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 @@ -520,8 +861,34 @@ _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 +#if MIN_VERSION_base(4,21,0) getErrorCall (ErrorCall x) = x +#else +getErrorCall (ErrorCallWithLocation x _) = x +#endif {-# INLINE getErrorCall #-} getRecUpdError :: RecUpdError -> String @@ -548,14 +915,383 @@ failedAssertion (AssertionFailed x) = x {-# INLINE failedAssertion #-} -getArrowMonad :: ArrowApply m => ArrowMonad m a -> m () a -getArrowMonad (ArrowMonad x) = x -{-# INLINE getArrowMonad #-} +-- * Foreign.C.Types --- | Given the constructor for a 'Wrapped' type, return a +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 'Wrapped' instance is legal, these laws hold: +-- Assuming the t'Wrapped' instance is legal, these laws hold: -- -- @ -- 'op' f '.' f ≡ 'id' @@ -619,21 +1355,30 @@ -- >>> ala Any foldMap [True,False] -- True -- --- >>> ala Sum foldMap [1,2,3,4] --- 10 --- -- >>> ala Product foldMap [1,2,3,4] -- 24 -ala :: Rewrapping s t => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> e -> s) -> e -> Unwrapped s -ala = au . _Unwrapping +-- +-- +-- 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 Sum foldMap length ["hello","world"] +-- @ +-- 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 :: (Profunctor p, Rewrapping s t) => (Unwrapped s -> s) -> (p r t -> e -> s) -> p r (Unwrapped t) -> e -> Unwrapped s -alaf = auf . _Unwrapping +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 #-} diff --git a/src/Control/Lens/Zoom.hs b/src/Control/Lens/Zoom.hs --- a/src/Control/Lens/Zoom.hs +++ b/src/Control/Lens/Zoom.hs @@ -1,17 +1,23 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -#ifdef TRUSTWORTHY +{-# 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-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -19,12 +25,16 @@ -- ------------------------------------------------------------------------------- module Control.Lens.Zoom - ( Magnify(..) + ( Magnified + , Magnify(..) , Zoom(..) + , Zoomed ) where +import Prelude () + import Control.Lens.Getter -import Control.Lens.Internal.Action +import Control.Lens.Internal.Prelude import Control.Lens.Internal.Zoom import Control.Lens.Type import Control.Monad @@ -36,37 +46,85 @@ import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Error -import Control.Monad.Trans.List +#if MIN_VERSION_mtl(2,3,0) +import Control.Monad.Trans.RWS.CPS as CPS +#endif +import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe -import Data.Monoid -import Data.Profunctor.Unsafe +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 --- >>> import Data.Map as Map +-- >>> 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 = Vars.f --- >>> let g :: Expr -> Expr; g = Vars.g --- >>> let h :: Expr -> Expr -> Expr; h = Vars.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 -- 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 +#if MIN_VERSION_mtl(2,3,0) +type instance Magnified (CPS.RWST a w s m) = EffectRWS w s m +#endif +type instance Magnified (IdentityT m) = Magnified m + +------------------------------------------------------------------------------ +-- 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 (Zoomed m ~ Zoomed n, MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where +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 'Simple' 'Control.Lens.Traversal.Traversal' over + -- When applied to a 'Control.Lens.Traversal.Traversal'' over -- multiple values, the actions for each target are executed sequentially -- and the results are aggregated. -- @@ -130,18 +188,31 @@ zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Lazy.runWriterT {-# INLINE zoom #-} -instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where - zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT - {-# INLINE zoom #-} - instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #. l (FocusingMay #. afb)) . liftM May . runMaybeT {-# INLINE zoom #-} +instance 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 @@ -166,7 +237,16 @@ -- >>> 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 -- @ @@ -176,8 +256,11 @@ -- 'magnify' :: ('Monoid' w, 'Monoid' c) => 'Fold' s a -> 'RWS' a w st c -> 'RWS' s w st c -- ... -- @ - magnify :: LensLike' (Magnified m c) a b -> m c -> n c + 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 #-} @@ -186,7 +269,7 @@ -- 'magnify' = 'views' -- @ instance Magnify ((->) b) ((->) a) b a where - magnify = views + 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 @@ -196,6 +279,12 @@ instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m) {-# INLINE magnify #-} + +#if MIN_VERSION_mtl(2,3,0) +instance (Monad m, Monoid w, MonadReader b (CPS.RWST b w s m)) => Magnify (CPS.RWST b w s m) (CPS.RWST a w s m) b a where + magnify l m = CPS.rwsT $ getEffectRWS #. l (EffectRWS #. CPS.runRWST m) + {-# INLINE magnify #-} +#endif instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where magnify l (IdentityT m) = IdentityT (magnify l m) diff --git a/src/Control/Monad/Error/Lens.hs b/src/Control/Monad/Error/Lens.hs --- a/src/Control/Monad/Error/Lens.hs +++ b/src/Control/Monad/Error/Lens.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Error.Lens --- Copyright : (C) 2014 Edward Kmett +-- Copyright : (C) 2014-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -24,38 +25,42 @@ , Handler(..) , Handleable(..) -- * Throwing - , throwing + , throwing, throwing_ ) where import Control.Applicative import Control.Lens import Control.Lens.Internal.Exception -import Control.Monad.Error +import Control.Monad +import Control.Monad.Error.Class import Data.Functor.Plus -import Data.Monoid +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 'Prism' (or any 'Getter', really). +-- | 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 => 'Getter' e a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadError' e m => 'Fold' e a -> m r -> (a -> m r) -> m r +-- 'catching' :: 'MonadError' e m => 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 (First a) 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 'Prism' (or any 'Getter'), discarding --- the information about the match. This is particuarly useful when you have --- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't +-- | 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. -- -- @ @@ -63,10 +68,10 @@ -- 'catching_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r --- 'catching_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r --- 'catching_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r +-- 'catching_' :: 'MonadError' e m => 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 (First a) 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_ #-} @@ -82,10 +87,10 @@ -- 'handling' :: 'MonadError' e m => 'Lens'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Traversal'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Iso'' e a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadError' e m => 'Fold' e a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadError' e m => 'Getter' e a -> (a -> m r) -> m r -> m r +-- 'handling' :: 'MonadError' e m => 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 (First a) 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 #-} @@ -97,10 +102,10 @@ -- 'handling_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r --- 'handling_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r --- 'handling_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r +-- 'handling_' :: 'MonadError' e m => 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 (First a) 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_ #-} @@ -108,18 +113,18 @@ -- Trying ------------------------------------------------------------------------------ --- | 'trying' takes a 'Prism' (or any 'Getter') to select which exceptions are caught --- If the 'Exception' does not match the predicate, it is re-thrown. +-- | 'trying' 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 => 'Getter' e a -> m r -> m ('Either' a r) --- 'trying' :: 'MonadError' e m => 'Fold' e a -> m r -> m ('Either' a r) +-- 'trying' :: 'MonadError' e m => 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 (First a) 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) ------------------------------------------------------------------------------ @@ -172,7 +177,7 @@ {-# INLINE fmap #-} instance Monad m => Semigroup (Handler e m a) where - (<>) = mappend + (<>) = () {-# INLINE (<>) #-} instance Monad m => Alt (Handler e m) where @@ -185,11 +190,13 @@ zero = Handler (const Nothing) undefined {-# INLINE zero #-} -instance Monad m => Monoid (Handler e m a) where +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 @@ -199,15 +206,15 @@ -- Throwing ------------------------------------------------------------------------------ --- | Throw an 'Exception' described by a 'Prism'. +-- | 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 => 'Prism'' e t -> t -> m a +-- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> m a -- @ -throwing :: MonadError e m => AReview e e t t -> t -> m x +throwing :: MonadError e m => AReview e t -> t -> m x throwing l = reviews l throwError {-# INLINE throwing #-} @@ -221,3 +228,15 @@ 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_ #-} diff --git a/src/Control/Monad/Primitive/Lens.hs b/src/Control/Monad/Primitive/Lens.hs deleted file mode 100644 --- a/src/Control/Monad/Primitive/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Primitive.Lens --- Copyright : (C) 2014 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Control.Monad.Primitive --- ----------------------------------------------------------------------------- -module Control.Monad.Primitive.Lens - ( - prim - ) where - -import Control.Lens -import Control.Monad.Primitive (PrimMonad(..)) -import GHC.Prim (State#) - -{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} - -prim :: (PrimMonad m) => Iso' (m a) (State# (PrimState m) -> (# State# (PrimState m), a #)) -prim = iso internal primitive -{-# INLINE prim #-} diff --git a/src/Control/Parallel/Strategies/Lens.hs b/src/Control/Parallel/Strategies/Lens.hs --- a/src/Control/Parallel/Strategies/Lens.hs +++ b/src/Control/Parallel/Strategies/Lens.hs @@ -2,19 +2,19 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_parallel -#define MIN_VERSION_parallel(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL > 700) -#endif + +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Parallel.Strategies.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- --- A 'Lens' or 'Traversal' can be used to take the role of 'Traversable' in +-- 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. ---------------------------------------------------------------------------- @@ -28,7 +28,7 @@ import Control.Lens import Control.Parallel.Strategies --- | Evaluate the targets of a 'Lens' or 'Traversal' into a data structure +-- | Evaluate the targets of a t'Lens' or t'Traversal' into a data structure -- according to the given 'Strategy'. -- -- @ @@ -45,7 +45,7 @@ evalOf l = l {-# INLINE evalOf #-} --- | Evaluate the targets of a 'Lens' or 'Traversal' according into a +-- | 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'@ @@ -56,14 +56,10 @@ -- 'parOf' :: ((a -> 'Eval' a) -> s -> 'Eval' s) -> 'Strategy' a -> 'Strategy' s -- @ parOf :: LensLike' Eval s a -> Strategy a -> Strategy s -#if MIN_VERSION_parallel(3,2,0) parOf l s = l (rparWith s) -#else -parOf l s = l (rpar `dot` s) -#endif {-# INLINE parOf #-} --- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to +-- | 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. -- -- @ @@ -73,7 +69,7 @@ after s l f = l f $| s {-# INLINE after #-} --- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to +-- | 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. -- -- @ diff --git a/src/Control/Seq/Lens.hs b/src/Control/Seq/Lens.hs --- a/src/Control/Seq/Lens.hs +++ b/src/Control/Seq/Lens.hs @@ -1,13 +1,13 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Seq.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- --- A 'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. +-- A t'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. ---------------------------------------------------------------------------- module Control.Seq.Lens ( seqOf @@ -17,8 +17,8 @@ import Control.Seq import Data.Monoid --- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso', --- 'Getter' or 'Fold' according to the given strategy. +-- | 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 diff --git a/src/Data/Aeson/Lens.hs b/src/Data/Aeson/Lens.hs deleted file mode 100644 --- a/src/Data/Aeson/Lens.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DefaultSignatures #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------- --- | --- Copyright : (c) Edward Kmett 2013-2014, (c) Paul Wilson 2012 --- License : BSD3 --- Maintainer: Edward Kmett --- Stability : experimental --- Portability: non-portable --- --------------------------------------------------------------------- -module Data.Aeson.Lens - ( - -- * Numbers - AsNumber(..) - , _Integral - , nonNull - -- * Primitive - , Primitive(..) - , AsPrimitive(..) - -- * Objects and Arrays - , AsValue(..) - , key, members - , nth, values - -- * Decoding - , AsJSON(..) - ) where - -import Control.Lens -import Data.Aeson -import Data.Scientific -import Data.ByteString.Lazy.Char8 as Lazy hiding (putStrLn) -import Data.ByteString.Lazy.UTF8 as UTF8 hiding (decode) -import Data.Data -import Data.HashMap.Strict (HashMap) -import Data.Text -import Data.Vector (Vector) -import Prelude hiding (null) - --- $setup --- >>> :set -XOverloadedStrings - ------------------------------------------------------------------------------- --- Scientific prisms ------------------------------------------------------------------------------- - -class AsNumber t where - -- | - -- >>> "[1, \"x\"]" ^? nth 0 . _Number - -- Just 1.0 - -- - -- >>> "[1, \"x\"]" ^? nth 1 . _Number - -- Nothing - _Number :: Prism' t Scientific -#ifndef HLINT - default _Number :: AsPrimitive t => Prism' t Scientific - _Number = _Primitive._Number - {-# INLINE _Number #-} -#endif - - -- | - -- Prism into an 'Double' over a 'Value', 'Primitive' or 'Scientific' - -- - -- >>> "[10.2]" ^? nth 0 . _Double - -- Just 10.2 - _Double :: Prism' t Double - _Double = _Number.iso realToFrac realToFrac - {-# INLINE _Double #-} - - -- | - -- Prism into an 'Integer' over a 'Value', 'Primitive' or 'Scientific' - -- - -- >>> "[10]" ^? nth 0 . _Integer - -- Just 10 - -- - -- >>> "[10.5]" ^? nth 0 . _Integer - -- Just 10 - _Integer :: Prism' t Integer - _Integer = _Number.iso floor fromIntegral - {-# INLINE _Integer #-} - -instance AsNumber Value where - _Number = prism Number $ \v -> case v of Number n -> Right n; _ -> Left v - {-# INLINE _Number #-} - -instance AsNumber Scientific where - _Number = id - {-# INLINE _Number #-} - -instance AsNumber ByteString -instance AsNumber String - ------------------------------------------------------------------------------- --- Conversion Prisms ------------------------------------------------------------------------------- - --- | Access Integer 'Value's as Integrals. --- --- >>> "[10]" ^? nth 0 . _Integral --- Just 10 --- --- >>> "[10.5]" ^? nth 0 . _Integral --- Just 10 -_Integral :: (AsNumber t, Integral a) => Prism' t a -_Integral = _Number . iso floor fromIntegral -{-# INLINE _Integral #-} - ------------------------------------------------------------------------------- --- Null values and primitives ------------------------------------------------------------------------------- - --- | Primitives of 'Value' -data Primitive - = StringPrim !Text - | NumberPrim !Scientific - | BoolPrim !Bool - | NullPrim - deriving (Eq,Ord,Show,Data,Typeable) - -instance AsNumber Primitive where - _Number = prism NumberPrim $ \v -> case v of NumberPrim s -> Right s; _ -> Left v - {-# INLINE _Number #-} - -class AsNumber t => AsPrimitive t where - -- | - -- >>> "[1, \"x\", null, true, false]" ^? nth 0 . _Primitive - -- Just (NumberPrim 1.0) - -- - -- >>> "[1, \"x\", null, true, false]" ^? nth 1 . _Primitive - -- Just (StringPrim "x") - -- - -- >>> "[1, \"x\", null, true, false]" ^? nth 2 . _Primitive - -- Just NullPrim - -- - -- >>> "[1, \"x\", null, true, false]" ^? nth 3 . _Primitive - -- Just (BoolPrim True) - -- - -- >>> "[1, \"x\", null, true, false]" ^? nth 4 . _Primitive - -- Just (BoolPrim False) - _Primitive :: Prism' t Primitive -#ifndef HLINT - default _Primitive :: AsValue t => Prism' t Primitive - _Primitive = _Value._Primitive - {-# INLINE _Primitive #-} -#endif - - -- "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _String - -- Just "xyz" - -- - -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _String - -- Nothing - _String :: Prism' t Text - _String = _Primitive.prism StringPrim (\v -> case v of StringPrim s -> Right s; _ -> Left v) - {-# INLINE _String #-} - - -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _Bool - -- Just True - -- - -- "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _Bool - -- Nothing - _Bool :: Prism' t Bool - _Bool = _Primitive.prism BoolPrim (\v -> case v of BoolPrim b -> Right b; _ -> Left v) - {-# INLINE _Bool #-} - - -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . _Null - -- Just () - -- - -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . _Null - -- Nothing - _Null :: Prism' t () - _Null = _Primitive.prism (const NullPrim) (\v -> case v of NullPrim -> Right (); _ -> Left v) - {-# INLINE _Null #-} - - -instance AsPrimitive Value where - _Primitive = prism fromPrim toPrim - where - toPrim (String s) = Right $ StringPrim s - toPrim (Number n) = Right $ NumberPrim n - toPrim (Bool b) = Right $ BoolPrim b - toPrim Null = Right NullPrim - toPrim v = Left v - {-# INLINE toPrim #-} - fromPrim (StringPrim s) = String s - fromPrim (NumberPrim n) = Number n - fromPrim (BoolPrim b) = Bool b - fromPrim NullPrim = Null - {-# INLINE fromPrim #-} - {-# INLINE _Primitive #-} - _String = prism String $ \v -> case v of String s -> Right s; _ -> Left v - {-# INLINE _String #-} - _Bool = prism Bool (\v -> case v of Bool b -> Right b; _ -> Left v) - {-# INLINE _Bool #-} - _Null = prism (const Null) (\v -> case v of Null -> Right (); _ -> Left v) - {-# INLINE _Null #-} - -instance AsPrimitive ByteString -instance AsPrimitive String - -instance AsPrimitive Primitive where - _Primitive = id - {-# INLINE _Primitive #-} - --- | Prism into non-'Null' values --- --- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . nonNull --- Just (String "xyz") --- --- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . nonNull --- Just (Object fromList []) --- --- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . nonNull --- Nothing -nonNull :: Prism' Value Value -nonNull = prism id (\v -> if isn't _Null v then Right v else Left v) -{-# INLINE nonNull #-} - ------------------------------------------------------------------------------- --- Non-primitive traversals ------------------------------------------------------------------------------- - -class AsPrimitive t => AsValue t where - -- | - -- >>> "[1,2,3]" ^? _Value - -- Just (Array (fromList [Number 1.0,Number 2.0,Number 3.0])) - _Value :: Prism' t Value - - -- | - -- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . _Object - -- Just fromList [] - -- - -- >>> "{\"a\": {}, \"b\": null}" ^? key "b" . _Object - -- Nothing - _Object :: Prism' t (HashMap Text Value) - _Object = _Value.prism Object (\v -> case v of Object o -> Right o; _ -> Left v) - {-# INLINE _Object #-} - - -- | - -- >>> "[1,2,3]" ^? _Array - -- Just (fromList [Number 1.0,Number 2.0,Number 3.0]) - _Array :: Prism' t (Vector Value) - _Array = _Value.prism Array (\v -> case v of Array a -> Right a; _ -> Left v) - {-# INLINE _Array #-} - -instance AsValue Value where - _Value = id - {-# INLINE _Value #-} - -instance AsValue ByteString where - _Value = _JSON - {-# INLINE _Value #-} - -instance AsValue String where - _Value = iso UTF8.fromString UTF8.toString._Value - {-# INLINE _Value #-} - --- | --- Like 'ix', but for 'Object' with Text indices. This often has better --- inference than 'ix' when used with OverloadedStrings. --- --- >>> "{\"a\": 100, \"b\": 200}" ^? key "a" --- Just (Number 100.0) --- --- >>> "[1,2,3]" ^? key "a" --- Nothing -key :: AsValue t => Text -> Traversal' t Value -key i = _Object . ix i -{-# INLINE key #-} - --- | An indexed Traversal into Object properties --- --- >>> "{\"a\": 4, \"b\": 7}" ^@.. members --- [("a",Number 4.0),("b",Number 7.0)] --- --- >>> "{\"a\": 4, \"b\": 7}" & members . _Number *~ 10 --- "{\"a\":40,\"b\":70}" -members :: AsValue t => IndexedTraversal' Text t Value -members = _Object . itraversed -{-# INLINE members #-} - --- | Like 'ix', but for Arrays with Int indexes --- --- >>> "[1,2,3]" ^? nth 1 --- Just (Number 2.0) --- --- >>> "\"a\": 100, \"b\": 200}" ^? nth 1 --- Nothing --- --- >>> "[1,2,3]" & nth 1 .~ Number 20 --- "[1,20,3]" -nth :: AsValue t => Int -> Traversal' t Value -nth i = _Array . ix i -{-# INLINE nth #-} - --- | An indexed Traversal into Array elements --- --- >>> "[1,2,3]" ^.. values --- [Number 1.0,Number 2.0,Number 3.0] --- --- >>> "[1,2,3]" & values . _Number *~ 10 --- "[10,20,30]" -values :: AsValue t => IndexedTraversal' Int t Value -values = _Array . traversed -{-# INLINE values #-} - -class AsJSON t where - -- | A Prism into 'Value' on lazy 'ByteString's. - _JSON :: (FromJSON a, ToJSON a) => Prism' t a - -instance AsJSON Lazy.ByteString where - _JSON = prism' encode decode - {-# INLINE _JSON #-} - -instance AsJSON String where - _JSON = iso UTF8.fromString UTF8.toString._JSON - {-# INLINE _JSON #-} - -instance AsJSON Value where - _JSON = prism toJSON $ \x -> case fromJSON x of - Success y -> Right y; - _ -> Left x - {-# INLINE _JSON #-} diff --git a/src/Data/Array/Lens.hs b/src/Data/Array/Lens.hs --- a/src/Data/Array/Lens.hs +++ b/src/Data/Array/Lens.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Array.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -18,10 +18,10 @@ import Control.Lens import Data.Array.IArray hiding (index) --- | This 'setter' can be used to derive a new 'IArray' from an old 'IAarray' by +-- | 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/ 'Setter'. +-- This is a /contravariant/ t'Setter'. -- -- @ -- 'ixmap' ≡ 'over' '.' 'ixmapped' @@ -30,5 +30,5 @@ -- 'bounds' ('over' ('ixmapped' b) f arr) ≡ b -- @ ixmapped :: (IArray a e, Ix i, Ix j) => (i,i) -> IndexPreservingSetter (a j e) (a i e) i j -ixmapped = setting . ixmap +ixmapped i = setting $ ixmap i {-# INLINE ixmapped #-} diff --git a/src/Data/Bits/Lens.hs b/src/Data/Bits/Lens.hs --- a/src/Data/Bits/Lens.hs +++ b/src/Data/Bits/Lens.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Bits.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -16,46 +17,51 @@ , bitAt , bits , byteAt + , bytewise ) where +import Prelude () + import Control.Lens +import Control.Lens.Internal.Prelude import Control.Monad.State import Data.Bits -import Data.Functor 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 'Lens' or 'Setter'. +-- | Bitwise '.|.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .|.~ 6 $ ("hello",3) -- ("hello",7) -- -- @ --- ('.|.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t --- ('.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t --- ('.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t --- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => 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 'Lens' or 'Setter'. +-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .&.~ 7 $ ("hello",254) -- ("hello",6) -- -- @ --- ('.&.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t --- ('.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t --- ('.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t --- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => 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) @@ -76,7 +82,7 @@ l .&.= a = modify (l .&.~ a) {-# INLINE (.&.=) #-} --- | Modify the target(s) of a 'Lens'', 'Setter' or 'Traversal' by computing its bitwise '.|.' with another value. +-- | 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) @@ -91,31 +97,31 @@ l .|.= a = modify (l .|.~ a) {-# INLINE (.|.=) #-} --- | Bitwise '.|.' the target(s) of a 'Lens' (or 'Traversal'), returning the result +-- | 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 => 'Iso' s t a a -> a -> s -> (a, t) --- ('<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: 'Bits' a => 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 'Lens' or 'Traversal', returning the result +-- | 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 => 'Iso' s t a a -> a -> s -> (a, t) --- ('<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: 'Bits' a => 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) @@ -135,7 +141,7 @@ l <.&.= b = l <%= (.&. b) {-# INLINE (<.&.=) #-} --- | Modify the target(s) of a 'Lens'', (or 'Traversal') by computing its bitwise '.|.' with another value, +-- | 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) @@ -149,25 +155,77 @@ 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 'Lens' can be used to access the value of the nth bit in a number. +-- | This t'Lens' can be used to access the value of the nth bit in a number. -- --- @'bitAt' n@ is only a legal 'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@. +-- @'bitAt' n@ is only a legal t'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@. -- -- >>> 16^.bitAt 4 -- True @@ -186,7 +244,7 @@ -- | Get the nth byte, counting from the low end. -- --- @'byteAt' n@ is a legal 'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@ +-- @'byteAt' n@ is a legal t'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@ -- -- >>> (0xff00 :: Word16)^.byteAt 0 -- 0 @@ -213,13 +271,33 @@ -- >>> toListOf bits (5 :: Word8) -- [True,False,True,False,False,False,False,False] -- --- If you supply this an 'Integer', the result will be an infinite 'Traversal', which +-- 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 = Prelude.foldr step 0 <$> traverse g bs where +bits f b = foldr step 0 <$> traverse g bs where g n = (,) n <$> indexed f n (testBit b n) - bs = Prelude.takeWhile hasBit [0..] + 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 #-} diff --git a/src/Data/ByteString/Lazy/Lens.hs b/src/Data/ByteString/Lazy/Lens.hs --- a/src/Data/ByteString/Lazy/Lens.hs +++ b/src/Data/ByteString/Lazy/Lens.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lazy.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -13,18 +17,23 @@ 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 as Words -import Data.ByteString.Lazy.Char8 as Char8 +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'. -- @@ -37,7 +46,7 @@ -- >>> [104,101,108,108,111]^.packedBytes == Char8.pack "hello" -- True packedBytes :: Iso' [Word8] ByteString -packedBytes = iso Words.pack unpackLazy +packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} -- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a 'ByteString' into a list of bytes @@ -56,7 +65,7 @@ -- | Traverse the individual bytes in a 'ByteString'. -- --- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion +-- 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: @@ -68,7 +77,7 @@ -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False -- --- Note that when just using this as a 'Setter', @'setting' 'Data.ByteString.Lazy.map'@ +-- 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 @@ -88,7 +97,7 @@ -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString -packedChars = iso Char8.pack unpackLazy8 +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' @@ -113,7 +122,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- --- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion +-- 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: @@ -127,3 +136,11 @@ 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 diff --git a/src/Data/ByteString/Lens.hs b/src/Data/ByteString/Lens.hs --- a/src/Data/ByteString/Lens.hs +++ b/src/Data/ByteString/Lens.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -13,13 +16,15 @@ ( IsByteString(..) , unpackedBytes , unpackedChars + , pattern Bytes + , pattern Chars ) where import Control.Lens import Data.Word (Word8) -import Data.ByteString as Strict +import qualified Data.ByteString as Strict import qualified Data.ByteString.Strict.Lens as Strict -import Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Lens as Lazy -- | Traversals for ByteStrings. @@ -48,7 +53,7 @@ -- | Traverse each 'Word8' in a strict or lazy 'ByteString' -- -- - -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion + -- 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: @@ -69,7 +74,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- - -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion + -- 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: @@ -100,6 +105,14 @@ 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' -- diff --git a/src/Data/ByteString/Strict/Lens.hs b/src/Data/ByteString/Strict/Lens.hs --- a/src/Data/ByteString/Strict/Lens.hs +++ b/src/Data/ByteString/Strict/Lens.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -13,17 +16,22 @@ 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 as Words -import Data.ByteString.Char8 as Char8 +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' -- @@ -36,7 +44,7 @@ -- >>> [104,101,108,108,111]^.packedBytes -- "hello" packedBytes :: Iso' [Word8] ByteString -packedBytes = iso Words.pack unpackStrict +packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes @@ -55,7 +63,7 @@ -- | Traverse each 'Word8' in a 'ByteString'. -- --- This 'Traversal' walks the 'ByteString' in a tree-like fashion +-- 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: @@ -67,10 +75,10 @@ -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False -- --- Note that when just using this as a 'Setter', @'setting' 'Data.ByteString.map'@ +-- 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 0 +bytes = traversedStrictTree {-# INLINE bytes #-} -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a 'ByteString' @@ -87,7 +95,7 @@ -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString -packedChars = iso Char8.pack unpackStrict8 +packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a 'ByteString' @@ -112,7 +120,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- --- This 'Traversal' walks the 'ByteString' in a tree-like fashion +-- 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: @@ -124,5 +132,13 @@ -- >>> anyOf chars (== 'h') "hello" -- True chars :: IndexedTraversal' Int ByteString Char -chars = traversedStrictTree8 0 +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 diff --git a/src/Data/Complex/Lens.hs b/src/Data/Complex/Lens.hs --- a/src/Data/Complex/Lens.hs +++ b/src/Data/Complex/Lens.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Complex.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -22,13 +22,22 @@ , _magnitude , _phase , _conjugate + -- * Pattern Synonyms + , pattern Polar + , pattern Real + , pattern Imaginary + , pattern Conjugate ) where -import Control.Applicative +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 ≈ } @@ -41,11 +50,7 @@ -- a * 2 :+ b -- -- @'_realPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ -#if MIN_VERSION_base(4,4,0) _realPart :: Lens' (Complex a) a -#else -_realPart :: RealFloat a => Lens' (Complex a) a -#endif _realPart f (a :+ b) = (:+ b) <$> f a {-# INLINE _realPart #-} @@ -58,15 +63,11 @@ -- a :+ b * 2 -- -- @'_imagPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ -#if MIN_VERSION_base(4,4,0) _imagPart :: Lens' (Complex a) a -#else -_imagPart :: RealFloat a => Lens' (Complex a) a -#endif _imagPart f (a :+ b) = (a :+) <$> f b {-# INLINE _imagPart #-} --- | This isn't /quite/ a legal 'Lens'. Notably the +-- | This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- @@ -75,24 +76,34 @@ -- which flips the 'phase' and retains a positive 'magnitude'. So don't do -- that! -- --- Otherwise, this is a perfectly cromulent 'Lens'. +-- 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 'Lens'. Notably the +-- 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 'Lens'. +-- 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 @@ -107,14 +118,14 @@ -- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2 -- True -- --- This isn't /quite/ a legal 'Lens'. Notably the +-- 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 'Lens'. +-- 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) @@ -131,3 +142,7 @@ _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 diff --git a/src/Data/Data/Lens.hs b/src/Data/Data/Lens.hs --- a/src/Data/Data/Lens.hs +++ b/src/Data/Data/Lens.hs @@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} -#ifndef HLINT {-# LANGUAGE UnboxedTuples #-} -#endif {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} @@ -17,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Data.Lens --- Copyright : (C) 2012-2014 Edward Kmett, (C) 2006-2012 Neil Mitchell +-- Copyright : (C) 2012-2016 Edward Kmett, (C) 2006-2012 Neil Mitchell -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -64,17 +62,17 @@ import Data.IORef import Data.Monoid import GHC.Exts (realWorld#) +import Prelude -#ifdef HLINT -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Use foldl" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} -{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} -#endif +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 @@ -101,8 +99,8 @@ {-# 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 mightBe :: Maybe (Is s a) of - Just Data.Data.Lens.Refl -> f s +step f w s = w <*> case X.eqT :: Maybe (s X.:~: a) of + Just X.Refl -> f s Nothing -> tinplate f s {-# INLINE step #-} @@ -138,7 +136,7 @@ -- Automatic Traversal construction from field accessors ------------------------------------------------------------------------------ -data FieldException a = FieldException !Int a deriving Typeable +data FieldException a = FieldException !Int a instance Show (FieldException a) where showsPrec d (FieldException i _) = showParen (d > 10) $ @@ -262,17 +260,6 @@ {-# INLINE onceUpon' #-} ------------------------------------------------------------------------------- --- Type equality -------------------------------------------------------------------------------- - -data Is a b where - Refl :: Is a a - -mightBe :: (Typeable a, Typeable b) => Maybe (Is a b) -mightBe = gcast Data.Data.Lens.Refl -{-# INLINE mightBe #-} - -------------------------------------------------------------------------------- -- Data Box ------------------------------------------------------------------------------- @@ -282,7 +269,7 @@ } dataBox :: Data a => a -> DataBox -dataBox a = DataBox (typeOf a) a +dataBox a = DataBox (X.typeRep [a]) a {-# INLINE dataBox #-} -- partial, caught elsewhere @@ -306,8 +293,8 @@ [ (tRational, S.singleton tInteger) , (tInteger, S.empty) ] where - tRational = typeOf (undefined :: Rational) - tInteger = typeOf (undefined :: Integer ) + 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 @@ -331,13 +318,11 @@ where x' = f x {-# INLINE fixEq #-} -#ifndef HLINT -- | inlineable 'unsafePerformIO' inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-} -#endif ------------------------------------------------------------------------------- -- Cache @@ -388,8 +373,8 @@ hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b hitTest a b = Oracle $ \(c :: c) -> - case mightBe :: Maybe (Is c b) of - Just Data.Data.Lens.Refl -> Hit c + 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 @@ -400,10 +385,10 @@ ------------------------------------------------------------------------------- -biplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s -biplateData o f a0 = go2 a0 where +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 s = gfoldl (\x y -> x <*> go2 y) pure s + go = gfoldl (\x y -> x <*> go2 y) pure go2 :: Data d => d -> f d go2 s = case o s of Hit a -> f a @@ -411,10 +396,10 @@ Miss -> pure s {-# INLINE biplateData #-} -uniplateData :: forall f s a. (Applicative f, Data s, Typeable a) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s -uniplateData o f a0 = go a0 where +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 s = gfoldl (\x y -> x <*> go2 y) pure s + go = gfoldl (\x y -> x <*> go2 y) pure go2 :: Data d => d -> f d go2 s = case o s of Hit a -> f a diff --git a/src/Data/Dynamic/Lens.hs b/src/Data/Dynamic/Lens.hs --- a/src/Data/Dynamic/Lens.hs +++ b/src/Data/Dynamic/Lens.hs @@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -12,6 +14,7 @@ ---------------------------------------------------------------------------- module Data.Dynamic.Lens ( AsDynamic(..) + , pattern Data.Dynamic.Lens.Dynamic ) where import Control.Exception @@ -19,16 +22,16 @@ import Control.Lens import Data.Dynamic --- | Any 'Dynamic' can be thrown as an 'Exception' +-- | Any t'Dynamic' can be thrown as an t'Exception' class AsDynamic t where - -- | This 'Prism' allows you to traverse the typed value contained in a - -- 'Dynamic' where the type required by your function matches that - -- of the contents of the 'Dynamic', or construct a 'Dynamic' value - -- out of whole cloth. It can also be used to catch or throw a 'Dynamic' + -- | 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'' 'Dynamic' a + -- '_Dynamic' :: 'Typeable' a => 'Prism'' t'Dynamic' a -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'SomeException' a -- @ _Dynamic :: Typeable a => Prism' t a @@ -40,3 +43,7 @@ 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 diff --git a/src/Data/HashSet/Lens.hs b/src/Data/HashSet/Lens.hs --- a/src/Data/HashSet/Lens.hs +++ b/src/Data/HashSet/Lens.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.HashSet.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -16,12 +12,16 @@ 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 Data.HashSet as HashSet +import qualified Data.HashSet as HashSet +import Data.HashSet (HashSet, fromMap, toMap) +import Data.HashMap.Lazy (HashMap) import Data.Hashable -- $setup @@ -33,7 +33,7 @@ -- -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. -setmapped :: (Eq i, Hashable i, Eq j, Hashable j) => IndexPreservingSetter (HashSet i) (HashSet j) i j +setmapped :: (Eq j, Hashable j) => IndexPreservingSetter (HashSet i) (HashSet j) i j setmapped = setting HashSet.map {-# INLINE setmapped #-} @@ -49,3 +49,7 @@ 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 diff --git a/src/Data/IntSet/Lens.hs b/src/Data/IntSet/Lens.hs --- a/src/Data/IntSet/Lens.hs +++ b/src/Data/IntSet/Lens.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntSet.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -16,13 +16,15 @@ ) where import Control.Lens -import Data.IntSet as IntSet +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 'Fold' can be used to access the members of an '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 @@ -30,20 +32,20 @@ members = folding IntSet.toAscList {-# INLINE members #-} --- | This 'Setter' can be used to change the contents of an 'IntSet' by mapping +-- | 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 'Traversal' for a 'Set', because the number of +-- 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) (fromList [1,2,3,4]) +-- >>> 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 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'. +-- | 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] @@ -52,11 +54,11 @@ -- fromList [1,2,3] -- -- @ --- 'setOf' :: 'Getter' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Fold' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Iso'' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Lens'' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Traversal'' s 'Int' -> s -> 'IntSet' +-- 'setOf' :: 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 diff --git a/src/Data/List/Lens.hs b/src/Data/List/Lens.hs --- a/src/Data/List/Lens.hs +++ b/src/Data/List/Lens.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -11,83 +9,105 @@ -- -- Traversals for manipulating parts of a list. -- ----------------------------------------------------------------------------- -module Data.List.Lens - ( prefixed - , suffixed - , stripSuffix - -- * Deprecated - , strippingPrefix - , strippingSuffix - ) where - -import Control.Monad (guard) -import Control.Lens -import Data.Functor -import Data.List - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> import Debug.SimpleReflect.Expr --- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) --- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f --- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g - --- | A 'Prism' stripping a prefix from a list when used as a 'Traversal', or --- prepending that prefix when run backwards: +-- Additional optics for manipulating lists are present more +-- generically in this package. -- --- >>> "preview" ^? prefixed "pre" --- Just "view" +-- The 'Control.Lens.At.Ixed' class allows traversing the element at a +-- specific list index. -- --- >>> "review" ^? prefixed "pre" +-- >>> [0..10] ^? ix 4 +-- Just 4 +-- +-- >>> [0..5] & ix 4 .~ 2 +-- [0,1,2,3,2,5] +-- +-- >>> [0..10] ^? ix 14 -- Nothing -- --- >>> prefixed "pre" # "amble" --- "preamble" -prefixed :: Eq a => [a] -> Prism' [a] [a] -prefixed ps = prism' (ps ++) (stripPrefix ps) -{-# INLINE prefixed #-} - --- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or --- appending that suffix when run backwards: +-- >>> [0..5] & ix 14 .~ 2 +-- [0,1,2,3,4,5] -- --- >>> "review" ^? suffixed "view" --- Just "re" +-- The 'Control.Lens.Cons.Cons' and 'Control.Lens.Empty.AsEmpty' +-- classes provide 'Control.Lens.Prism.Prism's for list constructors. -- --- >>> "review" ^? suffixed "tire" +-- >>> [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" -suffixed :: Eq a => [a] -> Prism' [a] [a] -suffixed qs = prism' (++ qs) (stripSuffix qs) -{-# INLINE suffixed #-} - ------------------------------------------------------------------------------- --- Util ------------------------------------------------------------------------------- - -stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] -stripSuffix qs xs0 = go xs0 zs - where - zs = drp qs xs0 - drp (_:ps) (_:xs) = drp ps xs - drp [] xs = xs - drp _ [] = [] - go (_:xs) (_:ys) = go xs ys - go xs [] = zipWith const xs0 zs <$ guard (xs == qs) - go [] _ = Nothing -- impossible -{-# INLINE stripSuffix #-} - --- | This is a deprecated alias for 'prefixed'. -strippingPrefix :: Eq a => [a] -> Prism' [a] [a] -strippingPrefix = prefixed -{-# INLINE strippingPrefix #-} -{-# DEPRECATED strippingPrefix "Use 'prefixed'." #-} +-- +-- 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 --- | This is a deprecated alias for 'suffixed'. -strippingSuffix :: Eq a => [a] -> Prism' [a] [a] -strippingSuffix = suffixed -{-# INLINE strippingSuffix #-} -{-# DEPRECATED strippingSuffix "Use 'suffixed'." #-} +import Control.Lens.Prism (Prefixed(..), Suffixed(..)) +import Control.Lens.Internal.List (stripSuffix) +--- $setup +--- >>> :set -XNoOverloadedStrings +--- >>> import Control.Lens diff --git a/src/Data/List/Split/Lens.hs b/src/Data/List/Split/Lens.hs deleted file mode 100644 --- a/src/Data/List/Split/Lens.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- --- | --- Module : Data.List.Split.Lens --- Copyright : (C) 2012-2014 Edward Kmett, Alexander Altman --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Rank2Types --- --- Lenses for working with Data.List.Split --- ----------------------------------------------------------------------------- -module Data.List.Split.Lens - ( - -- * Splitting Folds - splitting - , splittingOn - , splittingOneOf - , splittingWhen - , endingBy - , endingByOneOf - , wordingBy - , liningBy - , chunking - , splittingPlaces - , splittingPlacesBlanks - -- * Lenses for 'Splitter' Internals - , delimiters - , delimiting - , condensing - , keepInitialBlanks - , keepFinalBlanks - ) where - -import Control.Lens -import Data.Monoid -import Data.List.Split -import Data.List.Split.Internals - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> import Control.Lens --- >>> import Numeric.Lens (hex) --- >>> import Data.Char (chr) - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' according to the given splitting strategy. --- --- @ --- 'splitting' :: 'Splitter' a -> 'Fold' s a -> 'Fold' s [a] --- @ -splitting :: Splitter a -> Getting (Endo [a]) s a -> Fold s [a] -splitting s l f = coerce . traverse f . split s . toListOf l -{-# INLINE splitting #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' on the given delimiter. --- --- Equivalent to @'splitting' '.' 'dropDelims' '.' 'onSublist'@. --- --- @ --- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] --- @ -splittingOn :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] -splittingOn s l f = coerce . traverse f . splitOn s . toListOf l -{-# INLINE splittingOn #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' on any of the given elements. --- --- Equivalent to @'splitting' '.' 'dropDelims' '.' 'oneOf'@. --- --- @ --- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] --- @ -splittingOneOf :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] -splittingOneOf s l f = coerce . traverse f . splitOneOf s . toListOf l -{-# INLINE splittingOneOf #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' on elements satisfying the given predicate. --- --- Equivalent to @'splitting' '.' 'dropDelims' '.' 'whenElt'@. --- --- @ --- 'splittingWhen' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] --- @ -splittingWhen :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] -splittingWhen s l f = coerce . traverse f . splitWhen s . toListOf l -{-# INLINE splittingWhen #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks terminated by the given delimiter. --- --- Equivalent to @'splitting' '.' 'dropDelims' '.' 'onSublist'@. --- --- @ --- 'endingBy' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] --- @ -endingBy :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] -endingBy s l f = coerce . traverse f . endBy s . toListOf l -{-# INLINE endingBy #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks terminated by any of the given elements. --- --- Equivalent to @'splitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'oneOf'@. --- --- @ --- 'endingByOneOf' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] --- @ -endingByOneOf :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] -endingByOneOf s l f = coerce . traverse f . endByOneOf s . toListOf l -{-# INLINE endingByOneOf #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into "words", with word boundaries indicated by the given predicate. --- --- Equivalent to @'splitting' '.' 'dropBlanks' '.' 'dropDelims' '.' 'whenElt'@. --- --- @ --- 'wordingBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] --- @ -wordingBy :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] -wordingBy s l f = coerce . traverse f . wordsBy s . toListOf l -{-# INLINE wordingBy #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into "lines", with line boundaries indicated by the given predicate. --- --- Equivalent to @'splitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'whenElt'@. --- --- @ --- 'liningBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] --- @ -liningBy :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] -liningBy s l f = coerce . traverse f . linesBy s . toListOf l -{-# INLINE liningBy #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into length-@n@ pieces. --- --- >>> "48656c6c6f20776f726c64"^..chunking 2 folded.hex.to chr --- "Hello world" --- --- @ --- 'chunking' :: 'Int' -> 'Fold' s a -> 'Fold' s [a] --- @ -chunking :: Int -- ^ @n@ - -> Getting (Endo [a]) s a -> Fold s [a] -chunking s l f = coerce . traverse f . chunksOf s . toListOf l -{-# INLINE chunking #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks of the given lengths, . --- --- @ --- 'splittingPlaces' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] --- @ -splittingPlaces :: Integral n => [n] -> Getting (Endo [a]) s a -> Fold s [a] -splittingPlaces s l f = coerce . traverse f . splitPlaces s . toListOf l -{-# INLINE splittingPlaces #-} - --- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into chunks of the given lengths. Unlike 'splittingPlaces', the output 'Fold' will always be the same length as the first input argument. --- --- @ --- 'splittingPlacesBlanks' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] --- @ -splittingPlacesBlanks :: Integral n => [n] -> Getting (Endo [a]) s a -> Fold s [a] -splittingPlacesBlanks s l f = coerce . traverse f . splitPlacesBlanks s . toListOf l -{-# INLINE splittingPlacesBlanks #-} - --- | Modify or retrieve the list of delimiters for a 'Splitter'. -delimiters :: Lens (Splitter a) (Splitter b) [a -> Bool] [b -> Bool] -delimiters f s@Splitter { delimiter = Delimiter ds } = f ds <&> \ds' -> s { delimiter = Delimiter ds' } -{-# INLINE delimiters #-} - --- | Modify or retrieve the policy for what a 'Splitter' to do with delimiters. -delimiting :: Lens' (Splitter a) DelimPolicy -delimiting f s@Splitter { delimPolicy = p } = f p <&> \p' -> s { delimPolicy = p' } -{-# INLINE delimiting #-} - --- | Modify or retrieve the policy for what a 'Splitter' should about consecutive delimiters. -condensing :: Lens' (Splitter a) CondensePolicy -condensing f s@Splitter { condensePolicy = p } = f p <&> \p' -> s { condensePolicy = p' } -{-# INLINE condensing #-} - --- | Modify or retrieve the policy for whether a 'Splitter' should drop an initial blank. -keepInitialBlanks :: Lens' (Splitter a) Bool -keepInitialBlanks f s@Splitter { initBlankPolicy = p } = f (keeps p) <&> \p' -> s { initBlankPolicy = end p' } -{-# INLINE keepInitialBlanks #-} - --- | Modify or retrieve the policy for whether a 'Splitter' should drop a final blank. -keepFinalBlanks :: Lens' (Splitter a) Bool -keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = f (keeps p) <&> \p' -> s { finalBlankPolicy = end p' } -{-# INLINE keepFinalBlanks #-} - --- utilities - -end :: Bool -> EndPolicy -end True = KeepBlank -end False = DropBlank -{-# INLINE end #-} - -keeps :: EndPolicy -> Bool -keeps KeepBlank = True -keeps DropBlank = False -{-# INLINE keeps #-} diff --git a/src/Data/Map/Lens.hs b/src/Data/Map/Lens.hs --- a/src/Data/Map/Lens.hs +++ b/src/Data/Map/Lens.hs @@ -1,4 +1,12 @@ --- | One of most commonly-asked questions about this package is whether +----------------------------------------------------------------------------- +-- | +-- 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. @@ -50,8 +58,43 @@ -- -- >>> preview traverseMax $ Map.fromList [(5, "Saturn"), (6, "Uranus")] -- Just "Uranus" -module Data.Map.Lens () where +-- +----------------------------------------------------------------------------- +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 diff --git a/src/Data/Sequence/Lens.hs b/src/Data/Sequence/Lens.hs --- a/src/Data/Sequence/Lens.hs +++ b/src/Data/Sequence/Lens.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Sequence.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -19,9 +19,14 @@ import Control.Applicative import Control.Lens import Data.Monoid -import Data.Sequence as Seq +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 @@ -42,12 +47,12 @@ -- >>> EmptyL ^. from viewL -- fromList [] -- --- >>> review viewL $ a :< fromList [b,c] +-- >>> 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 :< as -> a Seq.<| as + a Seq.:< as -> a Seq.<| as {-# INLINE viewL #-} -- | A 'Seq' is isomorphic to a 'ViewR' @@ -63,23 +68,23 @@ -- >>> EmptyR ^. from viewR -- fromList [] -- --- >>> review viewR $ fromList [a,b] :> c +-- >>> 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 :> a -> as Seq.|> a + as Seq.:> a -> as Seq.|> a {-# INLINE viewR #-} -- | Traverse the first @n@ elements of a 'Seq' -- --- >>> fromList [a,b,c,d,e] ^.. slicedTo 2 +-- >>> Seq.fromList [a,b,c,d,e] ^.. slicedTo 2 -- [a,b] -- --- >>> fromList [a,b,c,d,e] & slicedTo 2 %~ f +-- >>> Seq.fromList [a,b,c,d,e] & slicedTo 2 %~ f -- fromList [f a,f b,c,d,e] -- --- >>> fromList [a,b,c,d,e] & slicedTo 10 .~ x +-- >>> 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 @@ -88,13 +93,13 @@ -- | Traverse all but the first @n@ elements of a 'Seq' -- --- >>> fromList [a,b,c,d,e] ^.. slicedFrom 2 +-- >>> Seq.fromList [a,b,c,d,e] ^.. slicedFrom 2 -- [c,d,e] -- --- >>> fromList [a,b,c,d,e] & slicedFrom 2 %~ f +-- >>> Seq.fromList [a,b,c,d,e] & slicedFrom 2 %~ f -- fromList [a,b,f c,f d,f e] -- --- >>> fromList [a,b,c,d,e] & slicedFrom 10 .~ x +-- >>> 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 @@ -103,13 +108,13 @@ -- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' -- --- >>> fromList [a,b,c,d,e] & sliced 1 3 %~ f +-- >>> Seq.fromList [a,b,c,d,e] & sliced 1 3 %~ f -- fromList [a,f b,f c,d,e] --- >>> fromList [a,b,c,d,e] ^.. sliced 1 3 +-- >>> Seq.fromList [a,b,c,d,e] ^.. sliced 1 3 -- [f b,f c] -- --- >>> fromList [a,b,c,d,e] & sliced 1 3 .~ x +-- >>> 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 @@ -117,7 +122,7 @@ (m, r) -> itraverse (indexed f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-} --- | Construct a 'Seq' from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. +-- | 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"] @@ -126,8 +131,8 @@ -- fromList [1,2,3] -- -- @ --- 'seqOf' :: 'Getter' s a -> s -> 'Seq' a --- 'seqOf' :: 'Fold' s a -> s -> 'Seq' a +-- '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 diff --git a/src/Data/Set/Lens.hs b/src/Data/Set/Lens.hs --- a/src/Data/Set/Lens.hs +++ b/src/Data/Set/Lens.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} + +{-# LANGUAGE Trustworthy #-} + +#include "lens-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -17,12 +23,14 @@ import Control.Lens.Getter ( Getting, views ) import Control.Lens.Setter ( setting ) import Control.Lens.Type -import Data.Set as Set +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. @@ -30,9 +38,9 @@ -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. -- --- >>> over setmapped (+1) (fromList [1,2,3,4]) +-- >>> over setmapped (+1) (Set.fromList [1,2,3,4]) -- fromList [2,3,4,5] -setmapped :: (Ord i, Ord j) => IndexPreservingSetter (Set i) (Set j) i j +setmapped :: Ord j => IndexPreservingSetter (Set i) (Set j) i j setmapped = setting Set.map {-# INLINE setmapped #-} diff --git a/src/Data/Text/Lazy/Lens.hs b/src/Data/Text/Lazy/Lens.hs --- a/src/Data/Text/Lazy/Lens.hs +++ b/src/Data/Text/Lazy/Lens.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lazy.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -16,19 +15,33 @@ ---------------------------------------------------------------------------- module Data.Text.Lazy.Lens ( packed, unpacked + , _Text , text , builder , utf8 + , pattern Text ) where -import Control.Lens -import Data.ByteString.Lazy as ByteString -import Data.Text.Lazy as Text -import Data.Text.Lazy.Builder +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'. -- @@ -63,6 +76,18 @@ 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' . -- -- @ @@ -70,7 +95,7 @@ -- 'toLazyText' x ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder -builder = iso fromLazyText toLazyText +builder = iso Builder.fromLazyText Builder.toLazyText {-# INLINE builder #-} -- | Traverse the individual characters in a 'Text'. @@ -92,9 +117,24 @@ -- can be more efficient. text :: IndexedTraversal' Int Text Char text = unpacked . traversed -{-# INLINE text #-} +{-# INLINE [0] text #-} --- | Encode/Decode a lazy 'Text' to/from lazy 'ByteString', via UTF-8. +{-# 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. @@ -104,3 +144,7 @@ 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 diff --git a/src/Data/Text/Lens.hs b/src/Data/Text/Lens.hs --- a/src/Data/Text/Lens.hs +++ b/src/Data/Text/Lens.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -14,16 +14,27 @@ -- ---------------------------------------------------------------------------- module Data.Text.Lens - ( IsText(..), unpacked + ( IsText(..) + , unpacked + , _Text + , pattern Text ) where -import Control.Lens -import Data.Text as Strict +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 Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.Lens as Lazy -import Data.Text.Lazy.Builder +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'. @@ -51,6 +62,14 @@ 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'. -- -- @ @@ -67,6 +86,22 @@ 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 diff --git a/src/Data/Text/Strict/Lens.hs b/src/Data/Text/Strict/Lens.hs --- a/src/Data/Text/Strict/Lens.hs +++ b/src/Data/Text/Strict/Lens.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Strict.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -18,17 +17,30 @@ , builder , text , utf8 + , _Text + , pattern Text ) where -import Control.Lens +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.Text +import Data.Monoid +import qualified Data.Text as Strict +import Data.Text (Text) import Data.Text.Encoding import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder +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'. -- @@ -43,7 +55,7 @@ -- 'packed' ≡ 'iso' 'pack' 'unpack' -- @ packed :: Iso' String Text -packed = iso pack unpack +packed = iso Strict.pack Strict.unpack {-# INLINE packed #-} -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'. @@ -63,8 +75,17 @@ -- 'unpacked' ≡ 'iso' 'unpack' 'pack' -- @ unpacked :: Iso' Text String -unpacked = iso unpack pack +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' . -- -- @ @@ -72,7 +93,7 @@ -- 'toStrict' ('toLazyText' x) ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder -builder = iso fromText (toStrict . toLazyText) +builder = iso Builder.fromText (toStrict . Builder.toLazyText) {-# INLINE builder #-} -- | Traverse the individual characters in strict 'Text'. @@ -91,12 +112,31 @@ -- be more efficient. text :: IndexedTraversal' Int Text Char text = unpacked . traversed -{-# INLINE text #-} +{-# INLINE [0] text #-} --- | Encode/Decode a strict 'Text' to/from strict 'ByteString', via UTF-8. +{-# 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 diff --git a/src/Data/Tree/Lens.hs b/src/Data/Tree/Lens.hs --- a/src/Data/Tree/Lens.hs +++ b/src/Data/Tree/Lens.hs @@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} + + ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -15,11 +17,17 @@ , branches ) where +import Prelude () + +import Control.Lens.Internal.Prelude import Control.Lens -import Data.Functor import Data.Tree --- | A 'Lens' that focuses on the root of a 'Tree'. +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Tree + +-- | A t'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 [] -- 42 @@ -27,7 +35,7 @@ root f (Node a as) = (`Node` as) <$> f a {-# INLINE root #-} --- | A 'Lens' returning the direct descendants of the root of a 'Tree' +-- | A t'Lens' returning the direct descendants of the root of a 'Tree' -- -- @'view' 'branches' ≡ 'subForest'@ branches :: Lens' (Tree a) [Tree a] diff --git a/src/Data/Typeable/Lens.hs b/src/Data/Typeable/Lens.hs --- a/src/Data/Typeable/Lens.hs +++ b/src/Data/Typeable/Lens.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Typeable.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -18,10 +15,12 @@ , _gcast ) where -import Control.Applicative +import Prelude () + import Control.Lens +import Control.Lens.Internal.Prelude +import Data.Maybe (fromMaybe) import Data.Typeable -import Data.Maybe -- | A 'Traversal'' for working with a 'cast' of a 'Typeable' value. _cast :: (Typeable s, Typeable a) => Traversal' s a diff --git a/src/Data/Vector/Generic/Lens.hs b/src/Data/Vector/Generic/Lens.hs --- a/src/Data/Vector/Generic/Lens.hs +++ b/src/Data/Vector/Generic/Lens.hs @@ -4,10 +4,13 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif + +#include "lens-common.h" + ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Generic.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -24,23 +27,35 @@ , asStream , asStreamR , cloned + , converted -- * Lenses , sliced -- * Traversal of individual indices , ordinals + , vectorIx + , vectorTraverse ) where -import Control.Applicative -import Control.Lens -import Data.List (nub) -import Data.Monoid -import Data.Vector.Generic as V hiding (zip, filter, indexed) -import Data.Vector.Fusion.Stream (Stream) +import 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) -import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) -- $setup --- >>> import Data.Vector as Vector +-- >>> 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'. @@ -51,58 +66,58 @@ -- Attempting to return a longer or shorter vector will result in -- violations of the 'Lens' laws. -- --- >>> Vector.fromList [1..10] ^. sliced 2 5 --- fromList [3,4,5,6,7] +-- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] +-- True -- --- >>> Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0 --- fromList [1,2,0,0,0,0,0,8,9,10] +-- >>> (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 (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (V.toList v0) +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 --- fromList [8,15] +-- >>> (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 = fromList (toListOf l s) +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 --- fromList [1,2,3] +-- >>> ([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 => Iso' [a] (v a) -vector = iso fromList V.toList +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 'Stream' (or back.) -asStream :: Vector v a => Iso' (v a) (Stream a) -asStream = iso stream unstream +-- | 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 'Stream' from right to left (or +-- | Convert a 'Vector' to a finite 'Bundle' from right to left (or -- back.) -asStreamR :: Vector v a => Iso' (v a) (Stream a) -asStreamR = iso streamR unstreamR +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 clone new +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 force +forced = involuted V.force {-# INLINE forced #-} -- | This 'Traversal' will ignore any duplicates in the supplied list @@ -111,6 +126,28 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: Vector v a => [Int] -> IndexedTraversal' Int (v a) a -ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ nub $ filter (\i -> 0 <= i && i < l) is where - l = length v +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 diff --git a/src/Data/Vector/Lens.hs b/src/Data/Vector/Lens.hs --- a/src/Data/Vector/Lens.hs +++ b/src/Data/Vector/Lens.hs @@ -8,7 +8,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Data.Vector.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -28,68 +28,71 @@ , ordinals ) where -import Control.Applicative +import Prelude () + import Control.Lens -import Data.Vector as Vector hiding (zip, filter, indexed) -import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) -import Data.List (nub) -import Data.Monoid +import Control.Lens.Internal.List (ordinalNub) +import Control.Lens.Internal.Prelude +import qualified Data.Vector as V +import Data.Vector (Vector) --- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting --- at index @i@ from a 'Lens'. +-- $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 'Lens' if you do not change the length of the +-- 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 'Lens' laws. +-- violations of the t'Lens' laws. -- --- >>> Vector.fromList [1..10] ^. sliced 2 5 --- fromList [3,4,5,6,7] +-- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] +-- True -- --- >>> Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0 --- fromList [1,2,0,0,0,0,0,8,9,10] +-- >>> (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 (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (toList v0) +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) --- fromList [8,15] +-- >>> toVectorOf both (8,15) == Vector.fromList [8,15] +-- True toVectorOf :: Getting (Endo [a]) s a -> s -> Vector a -toVectorOf l s = fromList (toListOf l s) +toVectorOf l s = V.fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back) -- --- >>> [1,2,3] ^. vector --- fromList [1,2,3] +-- >>> [1,2,3] ^. vector == Vector.fromList [1,2,3] +-- True -- -- >>> [1,2,3] ^. vector . from vector -- [1,2,3] -- --- >>> Vector.fromList [0,8,15] ^. from vector . vector --- fromList [0,8,15] +-- >>> Vector.fromList [0,8,15] ^. from vector . vector == Vector.fromList [0,8,15] +-- True vector :: Iso [a] [b] (Vector a) (Vector b) -vector = iso fromList toList +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 force force +forced = iso V.force V.force {-# INLINE forced #-} --- | This 'Traversal' will ignore any duplicates in the supplied list +-- | 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 //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ nub $ filter (\i -> 0 <= i && i < l) is where - l = length v +ordinals is f v = fmap (v V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (length v) is {-# INLINE ordinals #-} - diff --git a/src/GHC/Generics/Lens.hs b/src/GHC/Generics/Lens.hs --- a/src/GHC/Generics/Lens.hs +++ b/src/GHC/Generics/Lens.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -28,7 +31,129 @@ -- package. ---------------------------------------------------------------------------- module GHC.Generics.Lens - ( module Generics.Deriving.Lens + ( + generic + , generic1 + , _V1 + , _U1 + , _Par1 + , _Rec1 + , _K1 + , _M1 + , _L1 + , _R1 + , _UAddr + , _UChar + , _UDouble + , _UFloat + , _UInt + , _UWord ) where -import Generics.Deriving.Lens +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 #-} diff --git a/src/Generics/Deriving/Lens.hs b/src/Generics/Deriving/Lens.hs deleted file mode 100644 --- a/src/Generics/Deriving/Lens.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Generics.Deriving.Lens --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : GHC --- --- Note: @Generics.Deriving@ exports a number of names that collide with @Control.Lens@. --- --- You can use hiding to mitigate this to an extent, and the following import --- represents a fair compromise for user code: --- --- > import Generics.Deriving hiding (from, to) --- --- You can use 'generic' to replace 'Generics.Deriving.from' and --- 'Generics.Deriving.to' from @Generics.Deriving@. ----------------------------------------------------------------------------- -module Generics.Deriving.Lens - ( - -- * Isomorphisms for @GHC.Generics@ - generic - , generic1 - -- * Generic Traversal - , tinplate - , GTraversal - ) where - -import Control.Applicative -import Control.Lens -import Data.Maybe (fromJust) -import Data.Typeable -import qualified GHC.Generics as Generic -import GHC.Generics hiding (from, to) - --- $setup --- >>> :set -XNoOverloadedStrings - --- | Convert from the data type to its representation (or back) --- --- >>> "hello"^.generic.from generic :: String --- "hello" -generic :: Generic a => Iso' a (Generic.Rep a b) -generic = iso Generic.from Generic.to -{-# INLINE generic #-} - --- | Convert from the data type to its representation (or back) -generic1 :: Generic1 f => Iso' (f a) (Rep1 f a) -generic1 = iso from1 to1 -{-# INLINE generic1 #-} - --- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurrence --- of something 'Typeable' anywhere in a container. --- --- >>> allOf tinplate (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"]) --- True --- --- >>> mapMOf_ tinplate putStrLn ("hello",[(2 :: Int, "world!")]) --- hello --- world! -tinplate :: (Generic a, GTraversal (Generic.Rep a), Typeable b) => Traversal' a b -tinplate = generic . tinplated True -{-# INLINE tinplate #-} - -maybeArg1Of :: Maybe c -> (c -> d) -> Maybe c -maybeArg1Of = const -{-# INLINE maybeArg1Of #-} - --- | Used to traverse 'Generic' data by 'uniplate'. -class GTraversal f where - tinplated :: Typeable b => Bool -> Traversal' (f a) b - -instance (Generic a, GTraversal (Generic.Rep a), Typeable a) => GTraversal (K1 i a) where - tinplated rec f (K1 a) = case cast a `maybeArg1Of` f of - Just b -> K1 . fromJust . cast <$> f b - Nothing | rec -> K1 <$> fmap generic (tinplated False) f a - | otherwise -> pure $ K1 a - {-# INLINE tinplated #-} - -instance GTraversal U1 where - tinplated _ _ U1 = pure U1 - {-# INLINE tinplated #-} - -instance (GTraversal f, GTraversal g) => GTraversal (f :*: g) where - tinplated _ f (x :*: y) = (:*:) <$> tinplated True f x <*> tinplated True f y - {-# INLINE tinplated #-} - -instance (GTraversal f, GTraversal g) => GTraversal (f :+: g) where - tinplated _ f (L1 x) = L1 <$> tinplated True f x - tinplated _ f (R1 x) = R1 <$> tinplated True f x - {-# INLINE tinplated #-} - -instance GTraversal a => GTraversal (M1 i c a) where - tinplated rec f (M1 x) = M1 <$> tinplated rec f x - {-# INLINE tinplated #-} - --- ? -instance (Traversable f, GTraversal g) => GTraversal (f :.: g) where - tinplated _ f (Comp1 fgp) = Comp1 <$> traverse (tinplated True f) fgp - {-# INLINE tinplated #-} diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -1,1812 +1,2986 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif -{-# LANGUAGE Rank2Types #-} - -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) 1 -#endif ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.TH.Lens --- Copyright : (C) 2012-2014 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 ----------------------------------------------------------------------------- -module Language.Haskell.TH.Lens - ( - -- * Traversals - HasName(..) - , HasTypeVars(..) - , SubstType(..) - , typeVars -- :: HasTypeVars t => Traversal' t Name - , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t - , conFields - , conNamedFields - -- * Lenses - -- ** Loc Lenses - , locFileName - , locPackage - , locModule - , locStart - , locEnd - -- ** FunDep Lenses - , funDepInputs - , funDepOutputs - -- ** Match Lenses - , matchPattern - , matchBody - , matchDeclarations - -- ** Fixity Lenses - , fixityPrecedence - , fixityDirection - -- ** Clause Lenses - , clausePattern - , clauseBody - , clauseDecs - -- ** FieldExp Lenses - , fieldExpName - , fieldExpExpression - -- ** FieldPat Lenses - , fieldPatName - , fieldPatPattern -#if MIN_VERSION_template_haskell(2,9,0) - -- ** TySynEqn Lenses - , tySynEqnPatterns - , tySynEqnResult -#endif - -- * Prisms - -- ** Info Prisms - , _ClassI - , _ClassOpI - , _TyConI - , _FamilyI - , _PrimTyConI - , _DataConI - , _VarI - , _TyVarI - -- ** Dec Prisms - , _FunD - , _ValD - , _DataD - , _NewtypeD - , _TySynD - , _ClassD - , _InstanceD - , _SigD - , _ForeignD -#if MIN_VERSION_template_haskell(2,8,0) - , _InfixD -#endif - , _PragmaD - , _FamilyD - , _DataInstD - , _NewtypeInstD - , _TySynInstD -#if MIN_VERSION_template_haskell(2,9,0) - , _ClosedTypeFamilyD - , _RoleAnnotD -#endif - -- ** Con Prisms - , _NormalC - , _RecC - , _InfixC - , _ForallC - -- ** Strict Prisms - , _IsStrict - , _NotStrict - , _Unpacked - -- ** Foreign Prisms - , _ImportF - , _ExportF - -- ** Callconv Prisms - , _CCall - , _StdCall - -- ** Safety Prisms - , _Unsafe - , _Safe - , _Interruptible - -- ** Pragma Prisms - , _InlineP - , _SpecialiseP -#if MIN_VERSION_template_haskell(2,8,0) - , _SpecialiseInstP - , _RuleP -#if MIN_VERSION_template_haskell(2,9,0) - , _AnnP -#endif - -- ** Inline Prisms - , _NoInline - , _Inline - , _Inlinable - -- ** RuleMatch Prisms - , _ConLike - , _FunLike - -- ** Phases Prisms - , _AllPhases - , _FromPhase - , _BeforePhase - -- ** RuleBndr Prisms - , _RuleVar - , _TypedRuleVar -#endif -#if MIN_VERSION_template_haskell(2,9,0) - -- ** AnnTarget Prisms - , _ModuleAnnotation - , _TypeAnnotation - , _ValueAnnotation -#endif - -- ** FunDep Prisms TODO make a lens - , _FunDep - -- ** FamFlavour Prisms - , _TypeFam - , _DataFam - -- ** FixityDirection Prisms - , _InfixL - , _InfixR - , _InfixN - -- ** Exp Prisms - , _VarE - , _ConE - , _LitE - , _AppE - , _InfixE - , _UInfixE - , _ParensE - , _LamE -#if MIN_VERSION_template_haskell(2,8,0) - , _LamCaseE -#endif - , _TupE - , _UnboxedTupE - , _CondE -#if MIN_VERSION_template_haskell(2,8,0) - , _MultiIfE -#endif - , _LetE - , _CaseE - , _DoE - , _CompE - , _ArithSeqE - , _ListE - , _SigE - , _RecConE - , _RecUpdE - -- ** Body Prisms - , _GuardedB - , _NormalB - -- ** Guard Prisms - , _NormalG - , _PatG - -- ** Stmt Prisms - , _BindS - , _LetS - , _NoBindS - , _ParS - -- ** Range Prisms - , _FromR - , _FromThenR - , _FromToR - , _FromThenToR - -- ** Lit Prisms - , _CharL - , _StringL - , _IntegerL - , _RationalL - , _IntPrimL - , _WordPrimL - , _FloatPrimL - , _DoublePrimL - , _StringPrimL - -- ** Pat Prisms - , _LitP - , _VarP - , _TupP - , _UnboxedTupP - , _ConP - , _InfixP - , _UInfixP - , _ParensP - , _TildeP - , _BangP - , _AsP - , _WildP - , _RecP - , _ListP - , _SigP - , _ViewP - -- ** Type Prisms - , _ForallT - , _AppT - , _SigT - , _VarT - , _ConT -#if MIN_VERSION_template_haskell(2,8,0) - , _PromotedT -#endif - , _TupleT - , _UnboxedTupleT - , _ArrowT - , _ListT -#if MIN_VERSION_template_haskell(2,8,0) - , _PromotedTupleT - , _PromotedNilT - , _PromotedConsT - , _StarT - , _ConstraintT - , _LitT -#endif - -- ** TyVarBndr Prisms - , _PlainTV - , _KindedTV -#if MIN_VERSION_template_haskell(2,8,0) - -- ** TyLit Prisms - , _NumTyLit - , _StrTyLit -#endif -#if !MIN_VERSION_template_haskell(2,10,0) - -- ** Pred Prisms - , _ClassP - , _EqualP -#endif -#if MIN_VERSION_template_haskell(2,9,0) - -- ** Role Prisms - , _NominalR - , _RepresentationalR -#endif - ) where - -import Control.Applicative -import Control.Lens.At -import Control.Lens.Getter -import Control.Lens.Setter -import Control.Lens.Fold -import Control.Lens.Lens -import Control.Lens.Prism -import Control.Lens.Tuple -import Control.Lens.Traversal -import Data.Map as Map hiding (toList,map) -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Set as Set hiding (toList,map) -import Data.Set.Lens -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -#if MIN_VERSION_template_haskell(2,8,0) -import Data.Word -#endif - --- | Has a 'Name' -class HasName t where - -- | Extract (or modify) the 'Name' of something - name :: Lens' t Name - -instance HasName TyVarBndr where - name f (PlainTV n) = PlainTV <$> f n - name f (KindedTV n k) = (`KindedTV` k) <$> f n - -instance HasName Name where - name = id - -instance HasName Con where - name f (NormalC n tys) = (`NormalC` tys) <$> f n - name f (RecC n tys) = (`RecC` tys) <$> f n - name f (InfixC l n r) = (\n' -> InfixC l n' r) <$> f n - name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con - --- | Provides for the extraction of free type variables, and alpha renaming. -class HasTypeVars t where - -- | When performing substitution into this traversal you're not allowed - -- to substitute in a name that is bound internally or you'll violate - -- the 'Traversal' laws, when in doubt generate your names with 'newName'. - typeVarsEx :: Set Name -> Traversal' t Name - -instance HasTypeVars TyVarBndr where - typeVarsEx s f b - | s^.contains (b^.name) = pure b - | otherwise = name f b - -instance HasTypeVars Name where - typeVarsEx s f n - | s^.contains n = pure n - | otherwise = f n - -instance HasTypeVars Type where - typeVarsEx s f (VarT n) = VarT <$> typeVarsEx s f n - typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r - typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t - typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty - where s' = s `Set.union` setOf typeVars bs - typeVarsEx _ _ t = pure t - -#if !MIN_VERSION_template_haskell(2,10,0) -instance HasTypeVars Pred where - typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts - typeVarsEx s f (EqualP l r) = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r -#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 - -instance HasTypeVars t => HasTypeVars [t] where - typeVarsEx s = traverse . typeVarsEx s - --- | Traverse /free/ type variables -typeVars :: HasTypeVars t => Traversal' t Name -typeVars = typeVarsEx mempty - --- | Substitute using a map of names in for /free/ type variables -substTypeVars :: HasTypeVars t => Map Name Name -> t -> t -substTypeVars m = over typeVars $ \n -> fromMaybe n (m^.at n) - --- | Provides substitution for types -class SubstType t where - -- | Perform substitution for types - substType :: Map Name Type -> t -> t - -instance SubstType Type where - substType m t@(VarT n) = fromMaybe t (m^.at n) - substType m (ForallT bs ctx ty) = ForallT bs (substType m' ctx) (substType m' ty) - where m' = foldrOf typeVars Map.delete m bs - substType m (SigT t k) = SigT (substType m t) k - substType m (AppT l r) = AppT (substType m l) (substType m r) - substType _ t = t - -instance SubstType t => SubstType [t] where - substType = map . substType - -#if !MIN_VERSION_template_haskell(2,10,0) -instance SubstType Pred where - substType m (ClassP n ts) = ClassP n (substType m ts) - substType m (EqualP l r) = substType m (EqualP l r) -#endif - --- | Provides a 'Traversal' of the types of each field of a constructor. -conFields :: Traversal' Con StrictType -conFields f (NormalC n fs) = NormalC n <$> traverse f fs -conFields f (RecC n fs) = RecC n <$> traverse sans_var fs - where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t) -conFields f (InfixC l n r) = InfixC <$> f l <*> pure n <*> f r -conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c - --- | 'Traversal' of the types of the /named/ fields of a constructor. -conNamedFields :: Traversal' Con VarStrictType -conNamedFields f (RecC n fs) = RecC n <$> traverse f fs -conNamedFields f (ForallC a b fs) = ForallC a b <$> conNamedFields f fs -conNamedFields _ c = pure c - --- Lenses and Prisms -locFileName :: Lens' Loc String -locFileName = lens loc_filename - $ \loc fn -> loc { loc_filename = fn } - -locPackage :: Lens' Loc String -locPackage = lens loc_package - $ \loc fn -> loc { loc_package = fn } - -locModule :: Lens' Loc String -locModule = lens loc_module - $ \loc fn -> loc { loc_module = fn } - -locStart :: Lens' Loc CharPos -locStart = lens loc_start - $ \loc fn -> loc { loc_start = fn } - -locEnd :: Lens' Loc CharPos -locEnd = lens loc_end - $ \loc fn -> loc { loc_end = fn } - -funDepInputs :: Lens' FunDep [Name] -funDepInputs = lens g s where - g (FunDep xs _) = xs - s (FunDep _ ys) xs = FunDep xs ys - -funDepOutputs :: Lens' FunDep [Name] -funDepOutputs = lens g s where - g (FunDep _ xs) = xs - s (FunDep ys _) = FunDep ys - -fieldExpName :: Lens' FieldExp Name -fieldExpName = _1 - -fieldExpExpression :: Lens' FieldExp Exp -fieldExpExpression = _2 - -fieldPatName :: Lens' FieldPat Name -fieldPatName = _1 - -fieldPatPattern :: Lens' FieldPat Pat -fieldPatPattern = _2 - -matchPattern :: Lens' Match Pat -matchPattern = lens g s where - g (Match p _ _) = p - s (Match _ x y) p = Match p x y - -matchBody :: Lens' Match Body -matchBody = lens g s where - g (Match _ b _) = b - s (Match x _ y) b = Match x b y - -matchDeclarations :: Lens' Match [Dec] -matchDeclarations = lens g s where - g (Match _ _ ds) = ds - s (Match x y _ ) = Match x y - -fixityPrecedence :: Lens' Fixity Int -fixityPrecedence = lens g s where - g (Fixity i _) = i - s (Fixity _ x) i = Fixity i x - -fixityDirection :: Lens' Fixity FixityDirection -fixityDirection = lens g s where - g (Fixity _ d) = d - s (Fixity i _) = Fixity i - -clausePattern :: Lens' Clause [Pat] -clausePattern = lens g s where - g (Clause ps _ _) = ps - s (Clause _ x y) ps = Clause ps x y - -clauseBody :: Lens' Clause Body -clauseBody = lens g s where - g (Clause _ b _) = b - s (Clause x _ y) b = Clause x b y - -clauseDecs :: Lens' Clause [Dec] -clauseDecs = lens g s where - g (Clause _ _ ds) = ds - s (Clause x y _ ) = Clause x y - -#if MIN_VERSION_template_haskell(2,8,0) -_ClassI :: Prism' Info (Dec, [InstanceDec]) -_ClassI - = prism remitter reviewer - where - remitter (x, y) = ClassI x y - reviewer (ClassI x y) = Right (x, y) - reviewer x = Left x - -_ClassOpI :: Prism' Info (Name, Type, ParentName, Fixity) -_ClassOpI - = prism remitter reviewer - where - remitter (x, y, z, w) = ClassOpI x y z w - reviewer (ClassOpI x y z w) = Right (x, y, z, w) - reviewer x = Left x - -#else -_ClassI :: Prism' Info (Dec, [Dec]) -_ClassI - = prism remitter reviewer - where - remitter (x, y) = ClassI x y - reviewer (ClassI x y) = Right (x, y) - reviewer x = Left x - -_ClassOpI :: Prism' Info (Name, Type, Name, Fixity) -_ClassOpI - = prism remitter reviewer - where - remitter (x, y, z, w) = ClassOpI x y z w - reviewer (ClassOpI x y z w) = Right (x, y, z, w) - reviewer x = Left x -#endif - -_TyConI :: Prism' Info Dec -_TyConI - = prism remitter reviewer - where - remitter = TyConI - reviewer (TyConI x) = Right x - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_FamilyI :: Prism' Info (Dec, [InstanceDec]) -_FamilyI - = prism remitter reviewer - where - remitter (x, y) = FamilyI x y - reviewer (FamilyI x y) = Right (x, y) - reviewer x = Left x - -_PrimTyConI :: Prism' Info (Name, Arity, Unlifted) -_PrimTyConI - = prism remitter reviewer - where - remitter (x, y, z) = PrimTyConI x y z - reviewer (PrimTyConI x y z) = Right (x, y, z) - reviewer x = Left x - -_DataConI :: Prism' Info (Name, Type, ParentName, Fixity) -_DataConI - = prism remitter reviewer - where - remitter (x, y, z, w) = DataConI x y z w - reviewer (DataConI x y z w) = Right (x, y, z, w) - reviewer x = Left x -#else -_FamilyI :: Prism' Info (Dec, [Dec]) -_FamilyI - = prism remitter reviewer - where - remitter (x, y) = FamilyI x y - reviewer (FamilyI x y) = Right (x, y) - reviewer x = Left x - -_PrimTyConI :: Prism' Info (Name, Int, Bool) -_PrimTyConI - = prism remitter reviewer - where - remitter (x, y, z) = PrimTyConI x y z - reviewer (PrimTyConI x y z) = Right (x, y, z) - reviewer x = Left x - -_DataConI :: Prism' Info (Name, Type, Name, Fixity) -_DataConI - = prism remitter reviewer - where - remitter (x, y, z, w) = DataConI x y z w - reviewer (DataConI x y z w) = Right (x, y, z, w) - reviewer x = Left x - -#endif - -_VarI :: Prism' Info (Name, Type, Maybe Dec, Fixity) -_VarI - = prism remitter reviewer - where - remitter (x, y, z, w) = VarI x y z w - reviewer (VarI x y z w) = Right (x, y, z, w) - reviewer x = Left x - -_TyVarI :: Prism' Info (Name, Type) -_TyVarI - = prism remitter reviewer - where - remitter (x, y) = TyVarI x y - reviewer (TyVarI x y) = Right (x, y) - reviewer x = Left x - -_FunD :: Prism' Dec (Name, [Clause]) -_FunD - = prism remitter reviewer - where - remitter (x, y) = FunD x y - reviewer (FunD x y) = Right (x, y) - reviewer x = Left x - -_ValD :: Prism' Dec (Pat, Body, [Dec]) -_ValD - = prism remitter reviewer - where - remitter (x, y, z) = ValD x y z - reviewer (ValD x y z) = Right (x, y, z) - reviewer x = Left x - -_DataD :: Prism' Dec (Cxt, Name, [TyVarBndr], [Con], [Name]) -_DataD - = prism remitter reviewer - where - remitter (x, y, z, w, u) = DataD x y z w u - reviewer (DataD x y z w u) = Right (x, y, z, w, u) - reviewer x = Left x - -_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndr], Con, [Name]) -_NewtypeD - = prism remitter reviewer - where - remitter (x, y, z, w, u) = NewtypeD x y z w u - reviewer (NewtypeD x y z w u) = Right (x, y, z, w, u) - reviewer x = Left x - -_TySynD :: Prism' Dec (Name, [TyVarBndr], Type) -_TySynD - = prism remitter reviewer - where - remitter (x, y, z) = TySynD x y z - reviewer (TySynD x y z) = Right (x, y, z) - reviewer x = Left x - -_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndr], [FunDep], [Dec]) -_ClassD - = prism remitter reviewer - where - remitter (x, y, z, w, u) = ClassD x y z w u - reviewer (ClassD x y z w u) = Right (x, y, z, w, u) - reviewer x = Left x - -_InstanceD :: Prism' Dec (Cxt, Type, [Dec]) -_InstanceD - = prism remitter reviewer - where - remitter (x, y, z) = InstanceD x y z - reviewer (InstanceD x y z) = Right (x, y, z) - reviewer x = Left x - -_SigD :: Prism' Dec (Name, Type) -_SigD - = prism remitter reviewer - where - remitter (x, y) = SigD x y - reviewer (SigD x y) = Right (x, y) - reviewer x = Left x - -_ForeignD :: Prism' Dec Foreign -_ForeignD - = prism remitter reviewer - where - remitter = ForeignD - reviewer (ForeignD x) = Right x - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_InfixD :: Prism' Dec (Fixity, Name) -_InfixD - = prism remitter reviewer - where - remitter (x, y) = InfixD x y - reviewer (InfixD x y) = Right (x, y) - reviewer x = Left x -#endif - -_PragmaD :: Prism' Dec Pragma -_PragmaD - = prism remitter reviewer - where - remitter = PragmaD - reviewer (PragmaD x) = Right x - reviewer x = Left x - -_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndr], Maybe Kind) -_FamilyD - = prism remitter reviewer - where - remitter (x, y, z, w) = FamilyD x y z w - reviewer (FamilyD x y z w) = Right (x, y, z, w) - reviewer x = Left x - -_DataInstD :: Prism' Dec (Cxt, Name, [Type], [Con], [Name]) -_DataInstD - = prism remitter reviewer - where - remitter (x, y, z, w, u) = DataInstD x y z w u - reviewer (DataInstD x y z w u) = Right (x, y, z, w, u) - reviewer x = Left x - -_NewtypeInstD :: Prism' Dec (Cxt, Name, [Type], Con, [Name]) -_NewtypeInstD - = prism remitter reviewer - where - remitter (x, y, z, w, u) = NewtypeInstD x y z w u - reviewer (NewtypeInstD x y z w u) = Right (x, y, z, w, u) - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,9,0) -_TySynInstD :: Prism' Dec (Name, TySynEqn) -_TySynInstD - = prism remitter reviewer - where - remitter (x, y) = TySynInstD x y - reviewer (TySynInstD x y) = Right (x, y) - reviewer x = Left x - -_ClosedTypeFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind, [TySynEqn]) -_ClosedTypeFamilyD - = prism remitter reviewer - where - remitter (x, y, z, w) = ClosedTypeFamilyD x y z w - reviewer (ClosedTypeFamilyD x y z w) = Right (x, y, z, w) - reviewer x = Left x - -_RoleAnnotD :: Prism' Dec (Name, [Role]) -_RoleAnnotD - = prism remitter reviewer - where - remitter (x, y) = RoleAnnotD x y - reviewer (RoleAnnotD x y) = Right (x, y) - reviewer x = Left x - -#else -_TySynInstD :: Prism' Dec (Name, [Type], Type) -_TySynInstD - = prism remitter reviewer - where - remitter (x, y, z) = TySynInstD x y z - reviewer (TySynInstD x y z) = Right (x, y, z) - reviewer x = Left x -#endif - -_NormalC :: - Prism' Con (Name, [StrictType]) -_NormalC - = prism remitter reviewer - where - remitter (x, y) = NormalC x y - reviewer (NormalC x y) = Right (x, y) - reviewer x = Left x - -_RecC :: - Prism' Con (Name, [VarStrictType]) -_RecC - = prism remitter reviewer - where - remitter (x, y) = RecC x y - reviewer (RecC x y) = Right (x, y) - reviewer x = Left x - -_InfixC :: - Prism' Con (StrictType, - Name, - StrictType) -_InfixC - = prism remitter reviewer - where - remitter (x, y, z) - = InfixC x y z - reviewer (InfixC x y z) - = Right (x, y, z) - reviewer x = Left x - -_ForallC :: Prism' Con ([TyVarBndr], Cxt, Con) -_ForallC - = prism remitter reviewer - where - remitter (x, y, z) - = ForallC x y z - reviewer (ForallC x y z) - = Right (x, y, z) - reviewer x = Left x - -_IsStrict :: Prism' Strict () -_IsStrict - = prism remitter reviewer - where - remitter () = IsStrict - reviewer IsStrict = Right () - reviewer x = Left x - -_NotStrict :: Prism' Strict () -_NotStrict - = prism remitter reviewer - where - remitter () = NotStrict - reviewer NotStrict = Right () - reviewer x = Left x - -_Unpacked :: Prism' Strict () -_Unpacked - = prism remitter reviewer - where - remitter () = Unpacked - reviewer Unpacked = Right () - reviewer x = Left x - -_ImportF :: Prism' Foreign (Callconv, Safety, String, Name, Type) -_ImportF - = prism remitter reviewer - where - remitter (x, y, z, w, u) - = ImportF x y z w u - reviewer (ImportF x y z w u) - = Right (x, y, z, w, u) - reviewer x = Left x - -_ExportF :: Prism' Foreign (Callconv, String, Name, Type) -_ExportF - = prism remitter reviewer - where - remitter (x, y, z, w) - = ExportF x y z w - reviewer (ExportF x y z w) - = Right (x, y, z, w) - reviewer x = Left x - -_CCall :: Prism' Callconv () -_CCall - = prism remitter reviewer - where - remitter () = CCall - reviewer CCall = Right () - reviewer x = Left x - -_StdCall :: Prism' Callconv () -_StdCall - = prism remitter reviewer - where - remitter () = StdCall - reviewer StdCall = Right () - reviewer x = Left x - -_Unsafe :: Prism' Safety () -_Unsafe - = prism remitter reviewer - where - remitter () = Unsafe - reviewer Unsafe = Right () - reviewer x = Left x - -_Safe :: Prism' Safety () -_Safe - = prism remitter reviewer - where - remitter () = Safe - reviewer Safe = Right () - reviewer x = Left x - -_Interruptible :: Prism' Safety () -_Interruptible - = prism remitter reviewer - where - remitter () = Interruptible - reviewer Interruptible = Right () - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_InlineP :: Prism' Pragma (Name, Inline, RuleMatch, Phases) -_InlineP - = prism remitter reviewer - where - remitter (x, y, z, w) - = InlineP x y z w - reviewer (InlineP x y z w) - = Right (x, y, z, w) - reviewer x = Left x - -_SpecialiseP :: Prism' Pragma (Name, Type, Maybe Inline, Phases) -_SpecialiseP - = prism remitter reviewer - where - remitter (x, y, z, w) - = SpecialiseP x y z w - reviewer (SpecialiseP x y z w) - = Right (x, y, z, w) - reviewer x = Left x -#else -_InlineP :: Prism' Pragma (Name, InlineSpec) -_InlineP - = prism remitter reviewer - where - remitter (x, y) - = InlineP x y - reviewer (InlineP x y) - = Right (x, y) - reviewer x = Left x - -_SpecialiseP :: Prism' Pragma (Name, Type, Maybe InlineSpec) -_SpecialiseP - = prism remitter reviewer - where - remitter (x, y, z) - = SpecialiseP x y z - reviewer (SpecialiseP x y z) - = Right (x, y, z) - reviewer x = Left x - --- TODO add lenses for InlineSpec -#endif - -#if MIN_VERSION_template_haskell(2,8,0) -_SpecialiseInstP :: Prism' Pragma Type -_SpecialiseInstP - = prism remitter reviewer - where - remitter = SpecialiseInstP - reviewer (SpecialiseInstP x) = Right x - reviewer x = Left x - -_RuleP :: Prism' Pragma (String, [RuleBndr], Exp, Exp, Phases) -_RuleP - = prism remitter reviewer - where - remitter (x, y, z, w, u) - = RuleP x y z w u - reviewer (RuleP x y z w u) - = Right (x, y, z, w, u) - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,9,0) -_AnnP :: Prism' Pragma (AnnTarget, Exp) -_AnnP - = prism remitter reviewer - where - remitter (x, y) = AnnP x y - reviewer (AnnP x y) = Right (x, y) - reviewer x = Left x -#endif - -_NoInline :: Prism' Inline () -_NoInline - = prism remitter reviewer - where - remitter () = NoInline - reviewer NoInline = Right () - reviewer x = Left x - -_Inline :: Prism' Inline () -_Inline - = prism remitter reviewer - where - remitter () = Inline - reviewer Inline = Right () - reviewer x = Left x - -_Inlinable :: Prism' Inline () -_Inlinable - = prism remitter reviewer - where - remitter () = Inlinable - reviewer Inlinable = Right () - reviewer x = Left x - -_ConLike :: Prism' RuleMatch () -_ConLike - = prism remitter reviewer - where - remitter () = ConLike - reviewer ConLike = Right () - reviewer x = Left x - -_FunLike :: Prism' RuleMatch () -_FunLike - = prism remitter reviewer - where - remitter () = FunLike - reviewer FunLike = Right () - reviewer x = Left x - -_AllPhases :: Prism' Phases () -_AllPhases - = prism remitter reviewer - where - remitter () = AllPhases - reviewer AllPhases = Right () - reviewer x = Left x - -_FromPhase :: Prism' Phases Int -_FromPhase - = prism remitter reviewer - where - remitter = FromPhase - reviewer (FromPhase x) = Right x - reviewer x = Left x - -_BeforePhase :: Prism' Phases Int -_BeforePhase - = prism remitter reviewer - where - remitter = BeforePhase - reviewer (BeforePhase x) = Right x - reviewer x = Left x - -_RuleVar :: Prism' RuleBndr Name -_RuleVar - = prism remitter reviewer - where - remitter = RuleVar - reviewer (RuleVar x) = Right x - reviewer x = Left x - -_TypedRuleVar :: Prism' RuleBndr (Name, Type) -_TypedRuleVar - = prism remitter reviewer - where - remitter (x, y) = TypedRuleVar x y - reviewer (TypedRuleVar x y) = Right (x, y) - reviewer x = Left x -#endif - -#if MIN_VERSION_template_haskell(2,9,0) -_ModuleAnnotation :: Prism' AnnTarget () -_ModuleAnnotation - = prism remitter reviewer - where - remitter () = ModuleAnnotation - reviewer ModuleAnnotation - = Right () - reviewer x = Left x - -_TypeAnnotation :: Prism' AnnTarget Name -_TypeAnnotation - = prism remitter reviewer - where - remitter = TypeAnnotation - reviewer (TypeAnnotation x) - = Right x - reviewer x = Left x - -_ValueAnnotation :: Prism' AnnTarget Name -_ValueAnnotation - = prism remitter reviewer - where - remitter = ValueAnnotation - reviewer (ValueAnnotation x) = Right x - reviewer x = Left x -#endif - -_FunDep :: Prism' FunDep ([Name], [Name]) -_FunDep - = prism remitter reviewer - where - remitter (x, y) = FunDep x y - reviewer (FunDep x y) = Right (x, y) - -_TypeFam :: Prism' FamFlavour () -_TypeFam - = prism remitter reviewer - where - remitter () = TypeFam - reviewer TypeFam = Right () - reviewer x = Left x - -_DataFam :: Prism' FamFlavour () -_DataFam - = prism remitter reviewer - where - remitter () = DataFam - reviewer DataFam = Right () - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,9,0) -tySynEqnPatterns :: Lens' TySynEqn [Type] -tySynEqnPatterns = lens g s where - g (TySynEqn xs _) = xs - s (TySynEqn _ y) xs = TySynEqn xs y - -tySynEqnResult :: Lens' TySynEqn Type -tySynEqnResult = lens g s where - g (TySynEqn _ x) = x - s (TySynEqn xs _) = TySynEqn xs -#endif - -_InfixL :: Prism' FixityDirection () -_InfixL - = prism remitter reviewer - where - remitter () = InfixL - reviewer InfixL = Right () - reviewer x = Left x - -_InfixR :: Prism' FixityDirection () -_InfixR - = prism remitter reviewer - where - remitter () = InfixR - reviewer InfixR = Right () - reviewer x = Left x - -_InfixN :: Prism' FixityDirection () -_InfixN - = prism remitter reviewer - where - remitter () = InfixN - reviewer InfixN = Right () - reviewer x = Left x - -_VarE :: Prism' Exp Name -_VarE - = prism remitter reviewer - where - remitter = VarE - reviewer (VarE x) = Right x - reviewer x = Left x - -_ConE :: Prism' Exp Name -_ConE - = prism remitter reviewer - where - remitter = ConE - reviewer (ConE x) = Right x - reviewer x = Left x - -_LitE :: Prism' Exp Lit -_LitE - = prism remitter reviewer - where - remitter = LitE - reviewer (LitE x) = Right x - reviewer x = Left x - -_AppE :: Prism' Exp (Exp, Exp) -_AppE - = prism remitter reviewer - where - remitter (x, y) = AppE x y - reviewer (AppE x y) = Right (x, y) - reviewer x = Left x - -_InfixE :: Prism' Exp (Maybe Exp, Exp, Maybe Exp) -_InfixE - = prism remitter reviewer - where - remitter (x, y, z) - = InfixE x y z - reviewer (InfixE x y z) - = Right (x, y, z) - reviewer x = Left x - -_UInfixE :: Prism' Exp (Exp, Exp, Exp) -_UInfixE - = prism remitter reviewer - where - remitter (x, y, z) - = UInfixE x y z - reviewer (UInfixE x y z) - = Right (x, y, z) - reviewer x = Left x - -_ParensE :: Prism' Exp Exp -_ParensE - = prism remitter reviewer - where - remitter = ParensE - reviewer (ParensE x) = Right x - reviewer x = Left x - -_LamE :: Prism' Exp ([Pat], Exp) -_LamE - = prism remitter reviewer - where - remitter (x, y) = LamE x y - reviewer (LamE x y) = Right (x, y) - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_LamCaseE :: Prism' Exp [Match] -_LamCaseE - = prism remitter reviewer - where - remitter = LamCaseE - reviewer (LamCaseE x) = Right x - reviewer x = Left x -#endif - -_TupE :: Prism' Exp [Exp] -_TupE - = prism remitter reviewer - where - remitter = TupE - reviewer (TupE x) = Right x - reviewer x = Left x - -_UnboxedTupE :: Prism' Exp [Exp] -_UnboxedTupE - = prism remitter reviewer - where - remitter = UnboxedTupE - reviewer (UnboxedTupE x) = Right x - reviewer x = Left x - -_CondE :: Prism' Exp (Exp, Exp, Exp) -_CondE - = prism remitter reviewer - where - remitter (x, y, z) - = CondE x y z - reviewer (CondE x y z) - = Right (x, y, z) - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_MultiIfE :: Prism' Exp [(Guard, Exp)] -_MultiIfE - = prism remitter reviewer - where - remitter = MultiIfE - reviewer (MultiIfE x) = Right x - reviewer x = Left x -#endif - -_LetE :: Prism' Exp ([Dec], Exp) -_LetE - = prism remitter reviewer - where - remitter (x, y) = LetE x y - reviewer (LetE x y) = Right (x, y) - reviewer x = Left x - -_CaseE :: Prism' Exp (Exp, [Match]) -_CaseE - = prism remitter reviewer - where - remitter (x, y) = CaseE x y - reviewer (CaseE x y) = Right (x, y) - reviewer x = Left x - -_DoE :: Prism' Exp [Stmt] -_DoE - = prism remitter reviewer - where - remitter = DoE - reviewer (DoE x) = Right x - reviewer x = Left x - -_CompE :: Prism' Exp [Stmt] -_CompE - = prism remitter reviewer - where - remitter = CompE - reviewer (CompE x) = Right x - reviewer x = Left x - -_ArithSeqE :: Prism' Exp Range -_ArithSeqE - = prism remitter reviewer - where - remitter = ArithSeqE - reviewer (ArithSeqE x) = Right x - reviewer x = Left x - -_ListE :: Prism' Exp [Exp] -_ListE - = prism remitter reviewer - where - remitter = ListE - reviewer (ListE x) = Right x - reviewer x = Left x - -_SigE :: Prism' Exp (Exp, Type) -_SigE - = prism remitter reviewer - where - remitter (x, y) = SigE x y - reviewer (SigE x y) = Right (x, y) - reviewer x = Left x - -_RecConE :: Prism' Exp (Name, [FieldExp]) -_RecConE - = prism remitter reviewer - where - remitter (x, y) = RecConE x y - reviewer (RecConE x y) = Right (x, y) - reviewer x = Left x - -_RecUpdE :: Prism' Exp (Exp, [FieldExp]) -_RecUpdE - = prism remitter reviewer - where - remitter (x, y) = RecUpdE x y - reviewer (RecUpdE x y) = Right (x, y) - reviewer x = Left x - -_GuardedB :: Prism' Body [(Guard, Exp)] -_GuardedB - = prism remitter reviewer - where - remitter = GuardedB - reviewer (GuardedB x) = Right x - reviewer x = Left x - -_NormalB :: Prism' Body Exp -_NormalB - = prism remitter reviewer - where - remitter = NormalB - reviewer (NormalB x) = Right x - reviewer x = Left x - -_NormalG :: Prism' Guard Exp -_NormalG - = prism remitter reviewer - where - remitter = NormalG - reviewer (NormalG x) = Right x - reviewer x = Left x - -_PatG :: Prism' Guard [Stmt] -_PatG - = prism remitter reviewer - where - remitter = PatG - reviewer (PatG x) = Right x - reviewer x = Left x - -_BindS :: Prism' Stmt (Pat, Exp) -_BindS - = prism remitter reviewer - where - remitter (x, y) = BindS x y - reviewer (BindS x y) = Right (x, y) - reviewer x = Left x - -_LetS :: Prism' Stmt [Dec] -_LetS - = prism remitter reviewer - where - remitter = LetS - reviewer (LetS x) = Right x - reviewer x = Left x - -_NoBindS :: Prism' Stmt Exp -_NoBindS - = prism remitter reviewer - where - remitter = NoBindS - reviewer (NoBindS x) = Right x - reviewer x = Left x - -_ParS :: Prism' Stmt [[Stmt]] -_ParS - = prism remitter reviewer - where - remitter = ParS - reviewer (ParS x) = Right x - reviewer x = Left x - -_FromR :: Prism' Range Exp -_FromR - = prism remitter reviewer - where - remitter = FromR - reviewer (FromR x) = Right x - reviewer x = Left x - -_FromThenR :: Prism' Range (Exp, Exp) -_FromThenR - = prism remitter reviewer - where - remitter (x, y) = FromThenR x y - reviewer (FromThenR x y) - = Right (x, y) - reviewer x = Left x - -_FromToR :: Prism' Range (Exp, Exp) -_FromToR - = prism remitter reviewer - where - remitter (x, y) = FromToR x y - reviewer (FromToR x y) = Right (x, y) - reviewer x = Left x - -_FromThenToR :: Prism' Range (Exp, Exp, Exp) -_FromThenToR - = prism remitter reviewer - where - remitter (x, y, z) - = FromThenToR x y z - reviewer (FromThenToR x y z) - = Right (x, y, z) - reviewer x = Left x - -_CharL :: Prism' Lit Char -_CharL - = prism remitter reviewer - where - remitter = CharL - reviewer (CharL x) = Right x - reviewer x = Left x - -_StringL :: Prism' Lit String -_StringL - = prism remitter reviewer - where - remitter = StringL - reviewer (StringL x) = Right x - reviewer x = Left x - -_IntegerL :: Prism' Lit Integer -_IntegerL - = prism remitter reviewer - where - remitter = IntegerL - reviewer (IntegerL x) = Right x - reviewer x = Left x - -_RationalL :: Prism' Lit Rational -_RationalL - = prism remitter reviewer - where - remitter = RationalL - reviewer (RationalL x) = Right x - reviewer x = Left x - -_IntPrimL :: Prism' Lit Integer -_IntPrimL - = prism remitter reviewer - where - remitter = IntPrimL - reviewer (IntPrimL x) = Right x - reviewer x = Left x - -_WordPrimL :: Prism' Lit Integer -_WordPrimL - = prism remitter reviewer - where - remitter = WordPrimL - reviewer (WordPrimL x) = Right x - reviewer x = Left x - -_FloatPrimL :: Prism' Lit Rational -_FloatPrimL - = prism remitter reviewer - where - remitter = FloatPrimL - reviewer (FloatPrimL x) = Right x - reviewer x = Left x - -_DoublePrimL :: Prism' Lit Rational -_DoublePrimL - = prism remitter reviewer - where - remitter = DoublePrimL - reviewer (DoublePrimL x) = Right x - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_StringPrimL :: Prism' Lit [Word8] -_StringPrimL - = prism remitter reviewer - where - remitter = StringPrimL - reviewer (StringPrimL x) = Right x - reviewer x = Left x -#else -_StringPrimL :: Prism' Lit String -_StringPrimL - = prism remitter reviewer - where - remitter = StringPrimL - reviewer (StringPrimL x) = Right x - reviewer x = Left x -#endif - -_LitP :: Prism' Pat Lit -_LitP - = prism remitter reviewer - where - remitter = LitP - reviewer (LitP x) = Right x - reviewer x = Left x - -_VarP :: Prism' Pat Name -_VarP - = prism remitter reviewer - where - remitter = VarP - reviewer (VarP x) = Right x - reviewer x = Left x - -_TupP :: Prism' Pat [Pat] -_TupP - = prism remitter reviewer - where - remitter = TupP - reviewer (TupP x) = Right x - reviewer x = Left x - -_UnboxedTupP :: Prism' Pat [Pat] -_UnboxedTupP - = prism remitter reviewer - where - remitter = UnboxedTupP - reviewer (UnboxedTupP x) = Right x - reviewer x = Left x - -_ConP :: Prism' Pat (Name, [Pat]) -_ConP - = prism remitter reviewer - where - remitter (x, y) = ConP x y - reviewer (ConP x y) = Right (x, y) - reviewer x = Left x - -_InfixP :: Prism' Pat (Pat, Name, Pat) -_InfixP - = prism remitter reviewer - where - remitter (x, y, z) - = InfixP x y z - reviewer (InfixP x y z) - = Right (x, y, z) - reviewer x = Left x -_UInfixP :: Prism' Pat (Pat, Name, Pat) -_UInfixP - = prism remitter reviewer - where - remitter (x, y, z) - = UInfixP x y z - reviewer (UInfixP x y z) - = Right (x, y, z) - reviewer x = Left x - -_ParensP :: Prism' Pat Pat -_ParensP - = prism remitter reviewer - where - remitter = ParensP - reviewer (ParensP x) = Right x - reviewer x = Left x - -_TildeP :: Prism' Pat Pat -_TildeP - = prism remitter reviewer - where - remitter = TildeP - reviewer (TildeP x) = Right x - reviewer x = Left x - -_BangP :: Prism' Pat Pat -_BangP - = prism remitter reviewer - where - remitter = BangP - reviewer (BangP x) = Right x - reviewer x = Left x - -_AsP :: Prism' Pat (Name, Pat) -_AsP - = prism remitter reviewer - where - remitter (x, y) = AsP x y - reviewer (AsP x y) = Right (x, y) - reviewer x = Left x - -_WildP :: Prism' Pat () -_WildP - = prism remitter reviewer - where - remitter () = WildP - reviewer WildP = Right () - reviewer x = Left x - -_RecP :: Prism' Pat (Name, [FieldPat]) -_RecP - = prism remitter reviewer - where - remitter (x, y) = RecP x y - reviewer (RecP x y) = Right (x, y) - reviewer x = Left x - -_ListP :: Prism' Pat [Pat] -_ListP - = prism remitter reviewer - where - remitter = ListP - reviewer (ListP x) = Right x - reviewer x = Left x - -_SigP :: Prism' Pat (Pat, Type) -_SigP - = prism remitter reviewer - where - remitter (x, y) = SigP x y - reviewer (SigP x y) = Right (x, y) - reviewer x = Left x - -_ViewP :: Prism' Pat (Exp, Pat) -_ViewP - = prism remitter reviewer - where - remitter (x, y) = ViewP x y - reviewer (ViewP x y) = Right (x, y) - reviewer x = Left x - -_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type) -_ForallT - = prism remitter reviewer - where - remitter (x, y, z) - = ForallT x y z - reviewer (ForallT x y z) - = Right (x, y, z) - reviewer x = Left x - -_AppT :: Prism' Type (Type, Type) -_AppT - = prism remitter reviewer - where - remitter (x, y) = AppT x y - reviewer (AppT x y) = Right (x, y) - reviewer x = Left x - -_SigT :: Prism' Type (Type, Kind) -_SigT - = prism remitter reviewer - where - remitter (x, y) = SigT x y - reviewer (SigT x y) = Right (x, y) - reviewer x = Left x - -_VarT :: Prism' Type Name -_VarT - = prism remitter reviewer - where - remitter = VarT - reviewer (VarT x) = Right x - reviewer x = Left x - -_ConT :: Prism' Type Name -_ConT - = prism remitter reviewer - where - remitter = ConT - reviewer (ConT x) = Right x - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_PromotedT :: Prism' Type Name -_PromotedT - = prism remitter reviewer - where - remitter = PromotedT - reviewer (PromotedT x) = Right x - reviewer x = Left x -#endif - -_TupleT :: Prism' Type Int -_TupleT - = prism remitter reviewer - where - remitter = TupleT - reviewer (TupleT x) = Right x - reviewer x = Left x - -_UnboxedTupleT :: Prism' Type Int -_UnboxedTupleT - = prism remitter reviewer - where - remitter = UnboxedTupleT - reviewer (UnboxedTupleT x) = Right x - reviewer x = Left x - -_ArrowT :: Prism' Type () -_ArrowT - = prism remitter reviewer - where - remitter () = ArrowT - reviewer ArrowT = Right () - reviewer x = Left x - -_ListT :: Prism' Type () -_ListT - = prism remitter reviewer - where - remitter () = ListT - reviewer ListT = Right () - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_PromotedTupleT :: Prism' Type Int -_PromotedTupleT - = prism remitter reviewer - where - remitter = PromotedTupleT - reviewer (PromotedTupleT x) = Right x - reviewer x = Left x - -_PromotedNilT :: Prism' Type () -_PromotedNilT - = prism remitter reviewer - where - remitter () = PromotedNilT - reviewer PromotedNilT = Right () - reviewer x = Left x - -_PromotedConsT :: Prism' Type () -_PromotedConsT - = prism remitter reviewer - where - remitter () = PromotedConsT - reviewer PromotedConsT = Right () - reviewer x = Left x - -_StarT :: Prism' Type () -_StarT - = prism remitter reviewer - where - remitter () = StarT - reviewer StarT = Right () - reviewer x = Left x - -_ConstraintT :: Prism' Type () -_ConstraintT - = prism remitter reviewer - where - remitter () = ConstraintT - reviewer ConstraintT = Right () - reviewer x = Left x - -_LitT :: Prism' Type TyLit -_LitT - = prism remitter reviewer - where - remitter = LitT - reviewer (LitT x) = Right x - reviewer x = Left x -#endif - -_PlainTV :: Prism' TyVarBndr Name -_PlainTV - = prism remitter reviewer - where - remitter = PlainTV - reviewer (PlainTV x) = Right x - reviewer x = Left x - -_KindedTV :: Prism' TyVarBndr (Name, Kind) -_KindedTV - = prism remitter reviewer - where - remitter (x, y) = KindedTV x y - reviewer (KindedTV x y) = Right (x, y) - reviewer x = Left x - -#if MIN_VERSION_template_haskell(2,8,0) -_NumTyLit :: Prism' TyLit Integer -_NumTyLit - = prism remitter reviewer - where - remitter = NumTyLit - reviewer (NumTyLit x) = Right x - reviewer x = Left x - -_StrTyLit :: Prism' TyLit String -_StrTyLit - = prism remitter reviewer - where - remitter = StrTyLit - reviewer (StrTyLit x) = Right x - reviewer x = Left x -#endif - -#if !MIN_VERSION_template_haskell(2,10,0) -_ClassP :: Prism' Pred (Name, [Type]) -_ClassP - = prism remitter reviewer - where - remitter (x, y) = ClassP x y - reviewer (ClassP x y) = Right (x, y) - reviewer x = Left x - -_EqualP :: Prism' Pred (Type, Type) -_EqualP - = prism remitter reviewer - where - remitter (x, y) = EqualP x y - reviewer (EqualP x y) = Right (x, y) - reviewer x = Left x -#endif - -#if MIN_VERSION_template_haskell(2,9,0) -_NominalR :: Prism' Role () -_NominalR - = prism remitter reviewer - where - remitter () = NominalR - reviewer NominalR = Right () - reviewer x = Left x - -_RepresentationalR :: Prism' Role () -_RepresentationalR - = prism remitter reviewer - where - remitter () = RepresentationalR - reviewer RepresentationalR = Right () - reviewer x = Left x - -_PhantomR :: Prism' Role () -_PhantomR - = prism remitter reviewer - where - remitter () = PhantomR - reviewer PhantomR = Right () - reviewer x = Left x - -_InferR :: Prism' Role () -_InferR - = prism remitter reviewer - where - remitter () = InferR - reviewer InferR = Right () - reviewer x = Left x +{-# 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 +#if MIN_VERSION_template_haskell(2,22,0) + -- ** NamespaceSpecifier Prisms + , _NoNamespaceSpecifier + , _TypeNamespaceSpecifier + , _DataNamespaceSpecifier +#endif + -- ** 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 +#if MIN_VERSION_template_haskell(2,22,0) + , _SCCP +#endif +#if MIN_VERSION_template_haskell(2,24,0) + , _SpecialiseEP +#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 +#if MIN_VERSION_template_haskell(2,22,0) + , _TypeE +#endif +#if MIN_VERSION_template_haskell(2,23,0) + , _ForallE + , _ForallVisE + , _ConstrainedE +#endif + -- ** Body Prisms + , _GuardedB + , _NormalB + -- ** 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 +#if MIN_VERSION_template_haskell(2,22,0) + , _TypeP + , _InvisP +#endif +#if MIN_VERSION_template_haskell(2,23,0) + , _OrP +#endif + -- ** Type Prisms + , _ForallT + , _AppT + , _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 + +#if MIN_VERSION_template_haskell(2,22,0) +_NoNamespaceSpecifier :: Prism' NamespaceSpecifier () +_NoNamespaceSpecifier + = prism' reviewer remitter + where + reviewer () = NoNamespaceSpecifier + remitter NoNamespaceSpecifier = Just () + remitter _ = Nothing + +_TypeNamespaceSpecifier :: Prism' NamespaceSpecifier () +_TypeNamespaceSpecifier + = prism' reviewer remitter + where + reviewer () = TypeNamespaceSpecifier + remitter TypeNamespaceSpecifier = Just () + remitter _ = Nothing + +_DataNamespaceSpecifier :: Prism' NamespaceSpecifier () +_DataNamespaceSpecifier + = prism' reviewer remitter + where + reviewer () = DataNamespaceSpecifier + remitter DataNamespaceSpecifier = Just () + remitter _ = Nothing +#endif + +_Overlappable :: Prism' Overlap () +_Overlappable = prism' reviewer remitter + where + 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', 'NamespaceSpecifier', 'Name') -- template-haskell-2.22+ +-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'Name') -- Earlier versions +-- @ +#if MIN_VERSION_template_haskell(2,22,0) +_InfixD :: Prism' Dec (Fixity, NamespaceSpecifier, Name) +_InfixD + = prism' reviewer remitter + where + reviewer (x, y, z) = InfixD x y z + remitter (InfixD x y z) = Just (x, y, z) + remitter _ = Nothing +#else +_InfixD :: Prism' Dec (Fixity, Name) +_InfixD + = prism' reviewer remitter + where + reviewer (x, y) = InfixD x y + remitter (InfixD x y) = Just (x, y) + remitter _ = Nothing +#endif + +_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 + +#if MIN_VERSION_template_haskell(2,22,0) +_SCCP :: Prism' Pragma (Name, Maybe String) +_SCCP + = prism' reviewer remitter + where + reviewer (x, y) = SCCP x y + remitter (SCCP x y) = Just (x, y) + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,24,0) +_SpecialiseEP :: Prism' Pragma (Maybe [TyVarBndr ()], [RuleBndr], Exp, Maybe Inline, Phases) +_SpecialiseEP + = prism' reviewer remitter + where + reviewer (x, y, z, w, u) = SpecialiseEP x y z w u + remitter (SpecialiseEP x y z w u) = Just (x, y, z, w, u) + remitter _ = Nothing +#endif + +_NoInline :: Prism' Inline () +_NoInline + = prism' reviewer remitter + 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 + +#if MIN_VERSION_template_haskell(2,22,0) +_TypeE :: Prism' Exp Type +_TypeE + = prism' reviewer remitter + where + reviewer = TypeE + remitter (TypeE x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,23,0) +_ForallE :: Prism' Exp ([TyVarBndr Specificity], Exp) +_ForallE + = prism' reviewer remitter + where + reviewer (x, y) = ForallE x y + remitter (ForallE x y) = Just (x, y) + remitter _ = Nothing + +_ForallVisE :: Prism' Exp ([TyVarBndr ()], Exp) +_ForallVisE + = prism' reviewer remitter + where + reviewer (x, y) = ForallVisE x y + remitter (ForallVisE x y) = Just (x, y) + remitter _ = Nothing + +_ConstrainedE :: Prism' Exp ([Exp], Exp) +_ConstrainedE + = prism' reviewer remitter + where + reviewer (x, y) = ConstrainedE x y + remitter (ConstrainedE x y) = Just (x, y) + remitter _ = Nothing +#endif + +_GuardedB :: Prism' Body [(Guard, Exp)] +_GuardedB + = prism' reviewer remitter + 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 + +#if MIN_VERSION_template_haskell(2,22,0) +_TypeP :: Prism' Pat Type +_TypeP + = prism' reviewer remitter + where + reviewer = TypeP + remitter (TypeP x) = Just x + remitter _ = Nothing + +_InvisP :: Prism' Pat Type +_InvisP + = prism' reviewer remitter + where + reviewer = InvisP + remitter (InvisP x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,23,0) +_OrP :: Prism' Pat (NonEmpty Pat) +_OrP + = prism' reviewer remitter + where + reviewer = OrP + remitter (OrP x) = Just x + remitter _ = Nothing +#endif + +_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) +_ForallT + = 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 diff --git a/src/Numeric/Lens.hs b/src/Numeric/Lens.hs --- a/src/Numeric/Lens.hs +++ b/src/Numeric/Lens.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -------------------------------------------------------------------------------- -- | -- Module : Numeric.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -22,21 +27,25 @@ , 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 'Prism' extracts can be used to model the fact that every 'Integral' +-- | This t'Prism' can be used to model the fact that every t'Integral' -- type is a subset of 'Integer'. -- --- Embedding through the 'Prism' only succeeds if the 'Integer' would pass +-- 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 @@ -44,14 +53,20 @@ 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 :: Integral a => Int -> Prism' String a +base :: (HasCallStack, Integral a) => Int -> Prism' String a base b | b < 2 || b > 36 = error ("base: Invalid base " ++ show b) | otherwise = prism intShow intRead @@ -65,14 +80,14 @@ {-# INLINE base #-} -- | Like 'Data.Char.intToDigit', but handles up to base-36 -intToDigit' :: Int -> Char +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' :: Char -> Int +digitToInt' :: HasCallStack => Char -> Int digitToInt' c = fromMaybe (error ("digitToInt': Invalid digit " ++ show c)) (digitToIntMay c) @@ -100,7 +115,7 @@ -- | A simpler variant of 'Numeric.readSigned' that supports any base, only -- recognizes an initial dash and doesn't know about parentheses readSigned' :: Real a => ReadS a -> ReadS a -readSigned' f ('-':xs) = f xs & mapped . _1 %~ negate +readSigned' f ('-':xs) = f xs <&> _1 %~ negate readSigned' f xs = f xs -- | @'binary' = 'base' 2@ @@ -159,8 +174,19 @@ -- -- Note: This errors for n = 0 -- --- >>> au (exponentiating 2._Unwrapping Sum) (foldMapOf each) (3,4) --- 5.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 diff --git a/src/Numeric/Natural/Lens.hs b/src/Numeric/Natural/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Natural/Lens.hs @@ -0,0 +1,85 @@ +{-# 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 diff --git a/src/System/Exit/Lens.hs b/src/System/Exit/Lens.hs --- a/src/System/Exit/Lens.hs +++ b/src/System/Exit/Lens.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Exit.Lens --- Copyright : (C) 2013-14 Edward Kmett +-- Copyright : (C) 2013-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional @@ -15,28 +19,27 @@ ( AsExitCode(..) , _ExitFailure , _ExitSuccess + , pattern ExitFailure_ + , pattern ExitSuccess_ ) where -import Control.Applicative +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 p f t where - -- | - -- @ - -- '_ExitCode' :: 'Equality'' 'ExitCode' 'ExitCode' - -- '_ExitCode' :: 'Prism'' 'SomeException' 'ExitCode' - -- @ - _ExitCode :: Optic' p f t ExitCode +class AsExitCode t where + _ExitCode :: Prism' t ExitCode -instance AsExitCode p f ExitCode where +instance AsExitCode ExitCode where _ExitCode = id {-# INLINE _ExitCode #-} -instance (Choice p, Applicative f) => AsExitCode p f SomeException where +instance AsExitCode SomeException where _ExitCode = exception {-# INLINE _ExitCode #-} @@ -46,20 +49,29 @@ -- '_ExitSuccess' :: 'Prism'' 'ExitCode' () -- '_ExitSuccess' :: 'Prism'' 'SomeException' () -- @ -_ExitSuccess :: (AsExitCode p f t, Choice p, Applicative f) => Optic' p f t () +_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 p f t, Choice p, Applicative f) => Optic' p f t 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 diff --git a/src/System/FilePath/Lens.hs b/src/System/FilePath/Lens.hs --- a/src/System/FilePath/Lens.hs +++ b/src/System/FilePath/Lens.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : System.FilePath.Lens --- Copyright : (C) 2012-14 Edward Kmett +-- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -17,7 +17,7 @@ , basename, directory, extension, filename ) where -import Control.Applicative ((<$>)) +import Prelude () import Control.Monad.State as State import System.FilePath @@ -26,34 +26,55 @@ , 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") +-- >>> (both ~ "bin" $ ("hello","world")) == ("hello" "bin", "world" "bin") +-- True -- -- @ --- ('~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a --- ('~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a --- ('~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a --- ('~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a +-- ('~') :: 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 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding a path. +-- | Modify the target(s) of a 'Lens'', 'Iso'', 'Setter'' or 'Traversal'' by adding a path. -- --- >>> execState (both = "bin") ("hello","world") --- ("hello/bin","world/bin") +-- >>> execState (both = "bin") ("hello","world") == ("hello" "bin", "world" "bin") +-- True -- -- @ -- ('=') :: 'MonadState' s m => 'Setter'' s 'FilePath' -> 'FilePath' -> m () @@ -66,7 +87,7 @@ {-# INLINE (=) #-} --- | Add a path onto the end of the target of a 'Lens' and return the result +-- | 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) @@ -74,7 +95,7 @@ {-# INLINE (<~) #-} --- | Add a path onto the end of the target of a 'Lens' into +-- | 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. @@ -83,30 +104,38 @@ {-# 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 extension. +-- | Modify the path by adding an extension. -- -- >>> both <.>~ "txt" $ ("hello","world") -- ("hello.txt","world.txt") -- -- @ --- ('<.>~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a --- ('<.>~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a --- ('<.>~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a --- ('<.>~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'String' -> s -> a +-- ('<.>~') :: 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 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding an extension. +-- | Modify the target(s) of a 'Lens'', 'Iso'', 'Setter'' or 'Traversal'' by adding an extension. -- -- >>> execState (both <.>= "txt") ("hello","world") -- ("hello.txt","world.txt") @@ -121,7 +150,7 @@ l <.>= b = State.modify (l <.>~ b) {-# INLINE (<.>=) #-} --- | Add an extension onto the end of the target of a 'Lens' and return the result +-- | 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")) @@ -132,7 +161,7 @@ {-# INLINE (<<.>~) #-} --- | Add an extension onto the end of the target of a 'Lens' into +-- | 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") @@ -143,48 +172,61 @@ 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 'Lens' for reading and writing to the basename +-- | A t'Lens' for reading and writing to the basename -- --- Note: This is 'not' a legal 'Lens' unless the outer 'FilePath' has both a directory +-- 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" +-- >>> (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 'Lens' for reading and writing to the directory +-- | A t'Lens' for reading and writing to the directory -- --- Note: this is /not/ a legal 'Lens' unless the outer 'FilePath' already has a directory component, +-- 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" +-- >>> (("long" "path" "name.txt") ^. directory) == "long" "path" +-- True directory :: Lens' FilePath FilePath directory f p = ( takeFileName p) <$> f (takeDirectory p) {-# INLINE directory #-} --- | A 'Lens' for reading and writing to the extension +-- | A t'Lens' for reading and writing to the extension -- --- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated +-- 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" +-- >>> (extension .~ ".png" $ "path" "name.txt") == "path" "name.png" +-- True extension :: Lens' FilePath FilePath extension f p = (n <.>) <$> f e where @@ -192,14 +234,14 @@ {-# INLINE extension #-} --- | A 'Lens' for reading and writing to the full filename +-- | A t'Lens' for reading and writing to the full filename -- --- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated +-- 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" +-- >>> (filename .~ "name.txt" $ "path" "name.png") == "path" "name.txt" +-- True filename :: Lens' FilePath FilePath filename f p = (takeDirectory p ) <$> f (takeFileName p) {-# INLINE filename #-} diff --git a/src/System/IO/Error/Lens.hs b/src/System/IO/Error/Lens.hs --- a/src/System/IO/Error/Lens.hs +++ b/src/System/IO/Error/Lens.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : System.IO.Error.Lens --- Copyright : (C) 2012-2014 Edward Kmett +-- Copyright : (C) 2012-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -60,6 +59,60 @@ -- * IOErrorType Prisms -- --- (These prisms are generated automatically) -makePrisms ''IOErrorType +_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 diff --git a/tests/BigRecord.hs b/tests/BigRecord.hs new file mode 100644 --- /dev/null +++ b/tests/BigRecord.hs @@ -0,0 +1,65 @@ +{-# 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 diff --git a/tests/T1024.hs b/tests/T1024.hs new file mode 100644 --- /dev/null +++ b/tests/T1024.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Test 'makeFieldsId', which requires NoFieldSelectors and +-- DuplicateRecordFields. This test consequently only works on GHC >= 9.2. +module T1024 where + +import Control.Lens + +data Taco = Taco + { hardShell :: Bool + , sauce :: Int + , filling :: String + } +data Burrito = Burrito + { sauce :: Int + , filling :: String + } +makeFieldsId ''Taco +makeFieldsId ''Burrito + +checkTacoHardShell :: Lens' Taco Bool +checkTacoHardShell = hardShell + +checkBurritoFilling :: Lens' Burrito String +checkBurritoFilling = filling diff --git a/tests/T799.hs b/tests/T799.hs new file mode 100644 --- /dev/null +++ b/tests/T799.hs @@ -0,0 +1,23 @@ +{-# 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 diff --git a/tests/T917.hs b/tests/T917.hs new file mode 100644 --- /dev/null +++ b/tests/T917.hs @@ -0,0 +1,41 @@ +{-# 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) diff --git a/tests/T972.hs b/tests/T972.hs new file mode 100644 --- /dev/null +++ b/tests/T972.hs @@ -0,0 +1,20 @@ +{-# 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) diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,19 @@ +----------------------------------------------------------------------------- +-- | +-- 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" diff --git a/tests/doctests.hsc b/tests/doctests.hsc deleted file mode 100644 --- a/tests/doctests.hsc +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- 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 provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -##if defined(mingw32_HOST_OS) -##if defined(i386_HOST_ARCH) -##define USE_CP -import Control.Applicative -import Control.Exception -import Foreign.C.Types -foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool -foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##elif defined(x86_64_HOST_ARCH) -##define USE_CP -import Control.Applicative -import Control.Exception -import Foreign.C.Types -foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool -foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##endif -##endif - --- | Run in a modified codepage where we can print UTF-8 values on Windows. -withUnicode :: IO a -> IO a -##ifdef USE_CP -withUnicode m = do - cp <- c_GetConsoleCP - (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp -##else -withUnicode m = m -##endif - -main :: IO () -main = withUnicode $ getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/tests/hlint.hs b/tests/hlint.hs deleted file mode 100644 --- a/tests/hlint.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (hlint) --- Copyright : (C) 2013-2014 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module runs HLint on the lens source tree. ------------------------------------------------------------------------------ -module Main where - -import Control.Monad -import Language.Haskell.HLint -import System.Environment -import System.Exit - -main :: IO () -main = do - args <- getArgs - hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args - unless (null hints) exitFailure diff --git a/tests/hunit.hs b/tests/hunit.hs --- a/tests/hunit.hs +++ b/tests/hunit.hs @@ -1,5 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} + ----------------------------------------------------------------------------- -- | -- Module : Main (hunit) @@ -16,18 +18,23 @@ -- of what is possible using the lens package; there are a great many use cases -- (and lens functions) that aren't covered. ----------------------------------------------------------------------------- -module Main where +module Main (main) where import Control.Lens import Control.Monad.State import Data.Char -import Data.List as List +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 -import Data.Map as Map -import Test.Framework.Providers.HUnit -import Test.Framework.TH -import Test.Framework -import Test.HUnit hiding (test) +#endif +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) data Point = @@ -72,8 +79,8 @@ { _points = [ Point { _x = 0, _y = 0 } , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] - , _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin") - , (Point { _x = 4, _y = 7 }, "Peak") ] + , _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 } } } @@ -223,16 +230,96 @@ test = points <<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_prepend_to_record_field = + (trig & points <>:~ [ origin ]) + @?= trig { _points = [ origin ] <> (trig & _points) } + +case_prepend_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points <>:= [ origin ] + trig' = trig { _points = [ origin ] <> (trig & _points) } + +case_prepend_to_record_field_and_access_new_value = + (trig & points <<>:~ [ origin ]) + @?= ([ origin ] <> _points trig, trig { _points = [ origin ] <> (trig & _points) }) + +case_prepend_to_state_record_field_and_access_new_value = do + runState test trig @?= ([ origin ] <> _points trig, trig') + where + test = points <<>:= [ origin ] + trig' = trig { _points = [ origin ] <> (trig & _points) } + +case_cons_to_record_field = + (trig & points <|~ origin) + @?= trig { _points = origin : (trig & _points) } + +case_cons_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points <|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_cons_to_record_field_and_access_new_value = + (trig & points <<|~ origin) + @?= (origin : _points trig, trig { _points = origin : (trig & _points) }) + +case_cons_to_state_record_field_and_access_new_value = + runState test trig @?= ([ origin ] <> _points trig, trig') + where + test = points <<|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_snoc_to_record_field = + (trig & points |>~ origin) + @?= trig { _points = (trig & _points) `snoc` origin } + +case_snoc_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points |>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + +case_snoc_to_record_field_and_access_new_value = + (trig & points <|>~ origin) + @?= (_points trig `snoc` origin, trig { _points = (trig & _points) `snoc` origin }) + +case_snoc_to_state_record_field_and_access_new_value = + runState test trig @?= (_points trig <> [ origin ], trig') + where + test = points <|>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + case_append_to_record_field_and_access_old_value = - (trig & points <<%~ (<>[origin])) + (trig & points <<<>~ [ origin ]) @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] }) case_append_to_state_record_field_and_access_old_value = do runState test trig @?= (_points trig, trig') where - test = points <<%= (<>[origin]) + test = points <<<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_cons_to_record_field_and_access_old_value = + (trig & points <<<|~ origin) + @?= (_points trig, trig { _points = origin : (trig & _points) }) + +case_cons_to_state_record_field_and_access_old_value = + runState test trig @?= (_points trig, trig') + where + test = points <<<|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_snoc_to_record_field_and_access_old_value = + (trig & points <<|>~ origin) + @?= (_points trig, trig { _points = (trig & _points) `snoc` origin }) + +case_snoc_to_state_record_field_and_access_old_value = + runState test trig @?= (_points trig, trig') + where + test = points <<|>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin" case_read_maybe_state_map_entry = @@ -246,18 +333,18 @@ case_modify_map_entry = (trig & labels.ix origin %~ List.map toUpper) - @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN") - , (Point { _x = 4, _y = 7 }, "Peak") ] } + @?= 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 = fromList [ (Point { _x = 0, _y = 0 }, "Origin") - , (Point { _x = 4, _y = 7 }, "Peak") - , (Point { _x = 8, _y = 0 }, "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 = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } + @?= trig { _labels = Map.fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } case_read_list_entry = (trig ^? points.element 0) @@ -275,5 +362,78 @@ , 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 [$testGroupGenerator] +main = defaultMain $ + testGroup "Main" + [ testCase "read record field" case_read_record_field + , testCase "read state record field" case_read_state_record_field + , testCase "read record field and apply function" case_read_record_field_and_apply_function + , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function + , testCase "write record field" case_write_record_field + , testCase "write state record field" case_write_state_record_field + , testCase "write record field and access new value" case_write_record_field_and_access_new_value + , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value + , testCase "write record field and access old value" case_write_record_field_and_access_old_value + , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value + , testCase "modify record field" case_modify_record_field + , testCase "modify state record field" case_modify_state_record_field + , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value + , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value + , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value + , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value + , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result + , testCase "increment record field" case_increment_record_field + , testCase "increment state record field" case_increment_state_record_field + , testCase "append to record field" case_append_to_record_field + , testCase "append to state record field" case_append_to_state_record_field + , testCase "prepend to record field" case_prepend_to_record_field + , testCase "prepend to state record field" case_prepend_to_state_record_field + , testCase "cons to record field" case_cons_to_record_field + , testCase "cons to state record field" case_cons_to_state_record_field + , testCase "snoc to record field" case_snoc_to_record_field + , testCase "snoc to state record field" case_snoc_to_state_record_field + , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value + , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value + , testCase "prepend to record field and access new value" case_prepend_to_record_field_and_access_new_value + , testCase "prepend to state record field and access new value" case_prepend_to_state_record_field_and_access_new_value + , testCase "cons to record field and access new value" case_cons_to_record_field_and_access_new_value + , testCase "cons to state record field and access new value" case_cons_to_state_record_field_and_access_new_value + , testCase "snoc to record field and access new value" case_snoc_to_record_field_and_access_new_value + , testCase "snoc to state record field and access new value" case_snoc_to_state_record_field_and_access_new_value + , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value + , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value + , testCase "cons to record field and access old value" case_cons_to_record_field_and_access_old_value + , testCase "cons to state record field and access old value" case_cons_to_state_record_field_and_access_old_value + , testCase "snoc to record field and access old value" case_snoc_to_record_field_and_access_old_value + , testCase "snoc to state record field and access old value" case_snoc_to_state_record_field_and_access_old_value + , testCase "read maybe map entry" case_read_maybe_map_entry + , testCase "read maybe state map entry" case_read_maybe_state_map_entry + , testCase "read map entry" case_read_map_entry + , testCase "read state map entry" case_read_state_map_entry + , testCase "modify map entry" case_modify_map_entry + , testCase "insert maybe map entry" case_insert_maybe_map_entry + , testCase "delete maybe map entry" case_delete_maybe_map_entry + , testCase "read list entry" case_read_list_entry + , testCase "write list entry" case_write_list_entry + , testCase "write through list entry" case_write_through_list_entry + , testCase "correct indexing strict text" case_correct_indexing_strict_text + , testCase "correct indexing lazy text" case_correct_indexing_lazy_text + , testCase "correct indexing strict bytestring" case_correct_indexing_strict_bytestring + , testCase "correct indexing lazy bytestring" case_correct_indexing_lazy_bytestring + ] diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,9 +1,15 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Main (properties) @@ -18,21 +24,19 @@ ----------------------------------------------------------------------------- module Main where -import Control.Applicative import Control.Lens import Test.QuickCheck -import Test.QuickCheck.Function -import Test.Framework.TH -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) import Data.Char (isAlphaNum, isAscii, toUpper) -import Data.Text.Strict.Lens -import Data.Maybe -import Data.List.Lens -import Data.Functor.Compose +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 @@ -46,6 +50,11 @@ 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) @@ -70,10 +79,10 @@ prop__Just = isPrism (_Just :: Prism' (Maybe Int) Int) -- Data.List.Lens -prop_strippingPrefix s = isPrism (strippingPrefix s :: Prism' String String) +prop_prefixed s = isPrism (prefixed s :: Prism' String String) -- Data.Text.Lens -prop_text s = s^.packed.from packed == s +prop_text s = s^.Text.packed.from Text.packed == s --prop_text = isIso packed -- Numeric.Lens @@ -90,11 +99,61 @@ ] prop_base_readFail (s :: String) = forAll (choose (2,36)) $ \b -> - not isValid ==> s ^? base b == Nothing + 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 = $defaultMainGenerator +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 + ] diff --git a/tests/templates.hs b/tests/templates.hs --- a/tests/templates.hs +++ b/tests/templates.hs @@ -4,7 +4,10 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | @@ -23,51 +26,74 @@ module Main where import Control.Lens -import Data.List (nub) -- import Test.QuickCheck (quickCheck) +import BigRecord () +import T799 () +import T917 () +import T972 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar --- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b') --- upgrades to: --- baz :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b') +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 --- quaffle :: Lens (Quux a b) (Quux a' b') Int Int --- quartz :: Lens (Quux a b) (Quux a' b') Double Double +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 --- gaffer :: Simple Lens (Quark a) a --- tape :: Simple Traversal (Quark a) a +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 --- a1 :: Simple Lens (Hadron a b) a --- a2 :: Simple Lens (Hadron a b) a --- c :: Lens (Hadron a b) (Hadron a b') b b' +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 --- terrain :: Simple Lens (Perambulation a b) a --- altitude :: Traversal (Perambulation a b) (Parambulation a b') b b' --- dunes :: Simple Traversal (Perambulation a b) a + +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 --- allTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a' +checkAllTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a' +checkAllTerrain = allTerrain + data LensCrafted a = Still { _still :: a } | Works { _still :: a } makeLenses ''LensCrafted --- still :: Lens (LensCrafted a) (LensCrafted b) a b -data Danger a = Zone { _highway :: a } - | Twilight -makeLensesWith (partialLenses .~ True $ buildTraversals .~ False $ lensRules) ''Danger --- highway :: Lens (Danger a) (Danger a') a a' +checkStill :: Lens (LensCrafted a) (LensCrafted b) a b +checkStill = still data Task a = Task { taskOutput :: a -> IO () @@ -77,22 +103,49 @@ 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 --- monoFoo :: HasMono t => Simple Lens t Int --- monoBar :: HasMono t => Simple Lens t Int +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 --- nuclear :: HasNucleosis t => Simple Lens t Mono +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 @@ -100,76 +153,179 @@ 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 ''Dude 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 +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 --- gaffer1 :: Lens' (Quark1 a) a --- tape1 :: Traversal (Quark1 a) (Quark1 b) a b -declareIso [d| - newtype WrappedInt = Wrap { unwrap :: Int } - data New = New Int - |] --- newtype WrappedInt = Wrap Int --- data New = New Int --- wrap :: Iso' Int WrappedInt --- unwrap :: Iso' WrappedInt Int --- new :: Iso' Int New +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 } --- _Lit :: Prism' Exp Int --- _Var :: Prism' Exp String --- _Lambda :: Prism' Exp (String, 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 --- _Banana :: Iso' Banana (Int, String) + +check_Banana :: Iso' Banana (Int, String) +check_Banana = _Banana + cavendish :: Banana cavendish = _Banana # (4, "Cavendish") -banana :: Iso' (Int, String) Banana -banana = from _Banana - data family Family a b c -#if __GLASGOW_HASKELL >= 706 declareLenses [d| data instance Family Int (a, b) a = FamilyInt { fm0 :: (b, a), fm1 :: Int } |] -- data instance Family Int (a, b) a = FamilyInt a b --- fm0 :: Lens (Family Int (a, b) a) (Family Int (a', b') a') (b, a) (b', a') --- fm1 :: Lens' (Family Int (a, b) a) Int -#endif +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 @@ -179,40 +335,146 @@ data Associated Int = AssociatedInt { mochi :: Double } method = id |] + -- instance Class Int where -- data Associated Int = AssociatedInt Double -- method = id --- mochi :: Iso' (Associated Int) Double -#if __GLASGOW_HASKELL >= 706 +checkMochi :: Iso' (Associated Int) Double +checkMochi = mochi + declareFields [d| data DeclaredFields f a - = DeclaredField1 { declaredFieldsA :: f a , declaredFieldsB :: Int } - | DeclaredField2 { declaredFieldsC :: String , declaredFieldsB :: Int } + = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int } + | DeclaredField2 { declaredFieldsC0 :: String , declaredFieldsB0 :: Int } deriving (Show) |] -declaredFieldsUse1 :: [Bool] -declaredFieldsUse1 = view fieldsA (DeclaredField1 [True] 0) +checkA0 :: HasA0 t a => Traversal' t a +checkA0 = a0 -declaredFieldsUse2 :: [DeclaredFields [] ()] -declaredFieldsUse2 = over (traverse.fieldsB) (+1) [DeclaredField1 [()] 0, DeclaredField2 "" 1] -#endif +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] + , _r2nub :: forall a. Eq a => [a] -> [a] } | C2 { _r2length :: forall a. [a] -> Int } makeLenses ''Rank2Tests -useFold1 :: Maybe [Bool] -useFold1 = C1 length nub ^? r2nub . to ($ [False,True,True]) -useFold2 :: Maybe [Bool] -useFold2 = C2 length ^? r2nub . to ($ [False,True,True]) -useLength :: Int -useLength = C1 length nub ^. r2length . to ($ [False,True,True]) +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" diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install deleted file mode 100644 --- a/travis/cabal-apt-install +++ /dev/null @@ -1,22 +0,0 @@ -#! /bin/bash -set -eu - -APT="sudo apt-get -q -y" -CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" - -$APT update -$APT install dctrl-tools - -# Find potential system packages to satisfy cabal dependencies -deps() -{ - local M='^\([^ ]\+\)-[0-9.]\+ (.*$' - local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' - local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ - | sed -ne "s/$M/$G/p" | sort -u)" - grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u -} - -$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special -$CABAL_INSTALL_DEPS --constraint='hlint installed' "$@" # Install the rest via Hackage - diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -1,16 +0,0 @@ --- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix --- --- This is particularly useful for travis-ci to get it to stop complaining --- about a broken build when everything is still correct on our end. --- --- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead --- --- To enable this, uncomment the before_script in .travis.yml - -remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive -remote-repo-cache: ~/.cabal/packages -world-file: ~/.cabal/world -build-summary: ~/.cabal/logs/build.log -remote-build-reporting: anonymous -install-dirs user -install-dirs global