diff --git a/.hlint.yaml b/.hlint.yaml --- a/.hlint.yaml +++ b/.hlint.yaml @@ -1,4 +1,4 @@ -- arguments: [--cpp-define=HLINT, --cpp-ansi, --cpp-include=include] +- arguments: [--cpp-ansi, --cpp-include=include] - ignore: {name: Reduce duplication} - ignore: {name: Redundant lambda} @@ -10,17 +10,12 @@ - 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.Zoom]} # Breaks code +- ignore: {name: Eta reduce, within: [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]} # Needed to support pre-AMP GHCs +- 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} -- fixity: "infixl 9 :>" -- fixity: "infixr 9 <.>, <., .>, ..." -- fixity: "infixr 9 #." -- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#" -- fixity: "infixr 8 ^!, ^@!" -- fixity: "infixr 4 ~, <~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, , ??" +- fixity: "infixr 9 ..." +- fixity: "infixl 1 &~" diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,190 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' -# -# To regenerate the script (for example after adjusting tested-with) run -# -# haskell-ci regenerate -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.10 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -notifications: - irc: - channels: - - irc.freenode.org#haskell-lens - skip_join: true - template: - - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-8.8.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-7.10.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-7.8.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-7.6.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.2","freeglut3-dev"]}} - os: linux - - compiler: ghc-7.4.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.2","freeglut3-dev"]}} - os: linux -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap" - - set -o pipefail - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - - if [ $HCNUMVER -ge 81000 ] ; then HLINTVER=$(cd /tmp && (${CABAL} v2-install -v $WITHCOMPILER --dry-run hlint --constraint='hlint ==2.2.*' | perl -ne 'if (/\bhlint-(\d+(\.\d+)*)\b/) { print "$1"; last; }')); echo "HLint version $HLINTVER" ; fi - - "if [ $HCNUMVER -ge 81000 ] ; then if [ ! -e $HOME/.hlint/hlint-$HLINTVER/hlint ]; then echo \"Downloading HLint version $HLINTVER\"; mkdir -p $HOME/.hlint; curl --write-out 'Status Code: %{http_code} Redirects: %{num_redirects} Total time: %{time_total} Total Dsize: %{size_download}\\n' --silent --location --output $HOME/.hlint/hlint-$HLINTVER.tar.gz \"https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz\"; tar -xzv -f $HOME/.hlint/hlint-$HLINTVER.tar.gz -C $HOME/.hlint; fi ; fi" - - if [ $HCNUMVER -ge 81000 ] ; then mkdir -p $CABALHOME/bin && ln -sf "$HOME/.hlint/hlint-$HLINTVER/hlint" $CABALHOME/bin/hlint ; fi - - if [ $HCNUMVER -ge 81000 ] ; then hlint --version ; fi - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ." >> cabal.project - echo "packages: ./examples" >> cabal.project - echo "packages: ./lens-properties" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-examples' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-properties' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lens|lens-examples|lens-properties)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - if [ -f "./examples/configure.ac" ]; then (cd "./examples" && autoreconf -i); fi - - if [ -f "./lens-properties/configure.ac" ]; then (cd "./lens-properties" && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_lens="$(find . -maxdepth 1 -type d -regex '.*/lens-[0-9.]*')" - - PKGDIR_lens_examples="$(find . -maxdepth 1 -type d -regex '.*/lens-examples-[0-9.]*')" - - PKGDIR_lens_properties="$(find . -maxdepth 1 -type d -regex '.*/lens-properties-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_lens}" >> cabal.project - echo "packages: ${PKGDIR_lens_examples}" >> cabal.project - echo "packages: ${PKGDIR_lens_properties}" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-examples' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-properties' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lens|lens-examples|lens-properties)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all - # HLint.. - - if [ $HCNUMVER -ge 81000 ] ; then (cd ${PKGDIR_lens} && hlint src) ; fi - - if [ $HCNUMVER -ge 81000 ] ; then (cd ${PKGDIR_lens_examples} && hlint .) ; fi - - if [ $HCNUMVER -ge 81000 ] ; then (cd ${PKGDIR_lens_properties} && hlint src) ; fi - # cabal check... - - (cd ${PKGDIR_lens} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_lens_examples} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_lens_properties} && ${CABAL} -vnormal check) - # haddock... - - if [ $HCNUMVER -lt 70600 ] || [ $HCNUMVER -ge 70800 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi - -# REGENDATA ("0.10",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,96 @@ +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`. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ Lens: Lenses, Folds, and Traversals ================================== -[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/lens) [![Build Status](https://secure.travis-ci.org/ekmett/lens.svg)](http://travis-ci.org/ekmett/lens) [![Hackage Deps](https://img.shields.io/hackage-deps/v/lens.svg)](http://packdeps.haskellers.com/reverse/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). @@ -203,18 +203,29 @@ 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 ``` + +Alternatively, you can use `makeLenses` to automatically derive isomorphisms for your own newtypes. e.g.. + +```hs +makeLenses ''Neither +``` + +will automatically derive + +```hs +nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d) +``` + +which behaves identically to `_Neither` above. There is also a fully operational, but simple game of [Pong](https://github.com/ekmett/lens/blob/master/examples/Pong.hs) in the [examples/](https://github.com/ekmett/lens/blob/master/examples/) folder. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,34 +1,6 @@ \begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -import Warning () -#endif - -import Distribution.Simple - +import Distribution.Simple (defaultMain) main :: IO () main = defaultMain - -#endif - \end{code} diff --git a/Warning.hs b/Warning.hs deleted file mode 100644 --- a/Warning.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Warning - {-# WARNING ["You are configuring this package without cabal-doctest installed.", - "The doctests test-suite will not work as a result.", - "To fix this, install cabal-doctest before configuring."] #-} - () where diff --git a/benchmarks/traversals.hs b/benchmarks/traversals.hs --- a/benchmarks/traversals.hs +++ b/benchmarks/traversals.hs @@ -20,27 +20,6 @@ import Criterion.Main import Criterion.Types -#if !(MIN_VERSION_bytestring(0,10,0)) -import Control.DeepSeq (NFData(..)) -import qualified Data.ByteString.Internal as BS -#endif - -#if !(MIN_VERSION_containers(0,5,0)) -import qualified Data.Foldable as F -#endif - -#if !(MIN_VERSION_bytestring(0,10,0)) -instance NFData BS.ByteString where - rnf (BS.PS _ _ _) = () -#endif - -#if !(MIN_VERSION_containers(0,5,0)) --- Sadly, containers doesn't export the constructor for Seq on older versions, --- so we'll have to settle for this inefficient implementation of rnf. -instance NFData a => NFData (S.Seq a) where - rnf = rnf . F.toList -#endif - main :: IO () main = defaultMainWith config [ diff --git a/examples/.hlint.yaml b/examples/.hlint.yaml --- a/examples/.hlint.yaml +++ b/examples/.hlint.yaml @@ -1,11 +1,4 @@ -- arguments: [--cpp-define=HLINT, --cpp-ansi] +- arguments: [--cpp-ansi] -- fixity: "infixl 9 :>" -- fixity: "infixr 9 <.>, <., .>, ..." -- fixity: "infixr 9 #." -- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#" -- fixity: "infixr 8 ^!, ^@!" -- fixity: "infixr 4 ~, <~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, , ??" +- 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/lens-examples.cabal b/examples/lens-examples.cabal --- a/examples/lens-examples.cabal +++ b/examples/lens-examples.cabal @@ -16,9 +16,7 @@ Pong Example build-type: Simple -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 +tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 @@ -42,7 +40,7 @@ build-depends: aeson, base >= 4.5 && < 5, - bytestring >= 0.9.1.10 && < 0.11, + bytestring >= 0.9.1.10 && < 0.12, data-default-class, ghc-prim, lens diff --git a/include/lens-common.h b/include/lens-common.h --- a/include/lens-common.h +++ b/include/lens-common.h @@ -32,7 +32,7 @@ #endif #ifndef MIN_VERSION_parallel -#define MIN_VERSION_parallel(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL > 700) +#define MIN_VERSION_parallel(x,y,z) defined(__GLASGOW_HASKELL__) #endif #ifndef MIN_VERSION_reflection diff --git a/lens-properties/.hlint.yaml b/lens-properties/.hlint.yaml --- a/lens-properties/.hlint.yaml +++ b/lens-properties/.hlint.yaml @@ -1,11 +1,4 @@ -- arguments: [--cpp-define=HLINT, --cpp-ansi] +- arguments: [--cpp-ansi] - ignore: { name: Use camelCase } -- fixity: "infixl 9 :>" -- fixity: "infixr 9 <.>, <., .>, ..." -- fixity: "infixr 9 #." -- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#" -- fixity: "infixr 8 ^!, ^@!" -- fixity: "infixr 4 ~, <~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, , ??" +- fixity: "infixr 9 ..." +- fixity: "infixl 1 &~" diff --git a/lens-properties/lens-properties.cabal b/lens-properties/lens-properties.cabal --- a/lens-properties/lens-properties.cabal +++ b/lens-properties/lens-properties.cabal @@ -2,7 +2,7 @@ category: Data, Lenses version: 4.11.1 license: BSD3 -cabal-version: >= 1.8 +cabal-version: >= 1.10 license-file: LICENSE author: Edward Kmett and Oliver Charles maintainer: Edward Kmett @@ -13,9 +13,7 @@ synopsis: QuickCheck properties for lens description: QuickCheck properties for lens. build-type: Simple -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 +tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 @@ -35,7 +33,7 @@ library build-depends: base >= 4.5 && < 5, - lens >= 4 && < 5, + lens >= 4 && < 6, QuickCheck >= 2.4 && < 2.15, transformers >= 0.2 && < 0.6 @@ -44,3 +42,4 @@ hs-source-dirs: src ghc-options: -Wall + default-language: Haskell2010 diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics -version: 4.19.2 +version: 5 license: BSD2 cabal-version: 1.18 license-file: LICENSE @@ -10,11 +10,9 @@ homepage: http://github.com/ekmett/lens/ bug-reports: http://github.com/ekmett/lens/issues copyright: Copyright (C) 2012-2016 Edward A. Kmett -build-type: Custom +build-type: Simple -- build-tools: cpphs -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 +tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 @@ -97,7 +95,6 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). extra-source-files: - .travis.yml .gitignore .hlint.yaml .vim.custom @@ -113,9 +110,6 @@ lens-properties/LICENSE lens-properties/Setup.hs lens-properties/lens-properties.cabal - travis/cabal-apt-install - travis/config - Warning.hs AUTHORS.markdown CHANGELOG.markdown README.markdown @@ -127,13 +121,6 @@ type: git location: https://github.com/ekmett/lens.git -custom-setup - setup-depends: - Cabal >= 1.10 && <3.3, - base >= 4.5 && <5, - cabal-doctest >= 1 && <1.1, - filepath - -- Enable benchmarking against Neil Mitchell's uniplate library for comparative performance analysis. Defaults to being turned off to avoid -- the extra dependency. -- @@ -152,21 +139,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 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 @@ -181,11 +158,6 @@ default: True manual: True --- Disallow unsafeCoerce -flag safe - default: False - manual: True - -- Assert that we are trustworthy when we can flag trustworthy default: True @@ -198,35 +170,40 @@ library build-depends: - array >= 0.3.0.2 && < 0.6, - base >= 4.5 && < 5, - base-orphans >= 0.5.2 && < 1, - bifunctors >= 5.1 && < 6, - bytestring >= 0.9.2.1 && < 0.11, - call-stack >= 0.1 && < 0.3, - comonad >= 4 && < 6, - contravariant >= 1.3 && < 2, - containers >= 0.4.0 && < 0.7, - distributive >= 0.3 && < 1, - filepath >= 1.2.0.0 && < 1.5, - free >= 4 && < 6, + array >= 0.5.0.0 && < 0.6, + assoc >= 1.0.2 && < 1.1, + base >= 4.7 && < 5, + base-orphans >= 0.5.2 && < 1, + bifunctors >= 5.1 && < 6, + bytestring >= 0.10.4.0 && < 0.12, + call-stack >= 0.1 && < 0.4, + comonad >= 5.0.7 && < 6, + containers >= 0.5.5.1 && < 0.7, + contravariant >= 1.3 && < 2, + distributive >= 0.3 && < 1, + exceptions >= 0.1.1 && < 1, + filepath >= 1.2.0.0 && < 1.5, + free >= 5.1.5 && < 6, ghc-prim, - hashable >= 1.1.2.3 && < 1.4, - kan-extensions >= 5 && < 6, - exceptions >= 0.1.1 && < 1, - mtl >= 2.0.1 && < 2.3, - parallel >= 3.1.0.1 && < 3.3, - profunctors >= 5.2.1 && < 6, - reflection >= 2.1 && < 3, - semigroupoids >= 5 && < 6, - tagged >= 0.4.4 && < 1, - template-haskell >= 2.4 && < 2.17, - th-abstraction >= 0.3 && < 0.4, - text >= 0.11 && < 1.3, - transformers >= 0.2 && < 0.6, - transformers-compat >= 0.4 && < 1, - unordered-containers >= 0.2.4 && < 0.3, - vector >= 0.9 && < 0.13 + hashable >= 1.1.2.3 && < 1.4, + indexed-traversable >= 0.1 && < 0.2, + indexed-traversable-instances >= 0.1 && < 0.2, + kan-extensions >= 5 && < 6, + mtl >= 2.0.1 && < 2.3, + parallel >= 3.1.0.1 && < 3.3, + profunctors >= 5.5.2 && < 6, + reflection >= 2.1 && < 3, + semigroupoids >= 5 && < 6, + strict >= 0.4 && < 0.5, + tagged >= 0.4.4 && < 1, + template-haskell >= 2.9.0.0 && < 2.18, + text >= 1.2.3.0 && < 1.3, + th-abstraction >= 0.4.1 && < 0.5, + these >= 1.1.1.1 && < 1.2, + transformers >= 0.3.0.0 && < 0.6, + transformers-compat >= 0.4 && < 1, + unordered-containers >= 0.2.10 && < 0.3, + vector >= 0.9 && < 0.13 if !impl(ghc >= 8.0) build-depends: @@ -238,13 +215,12 @@ nats >= 0.1 && < 1.2, void >= 0.5 && < 1 - if !impl(ghc >= 7.8) - build-depends: - type-equality >= 1 && < 2 + -- Control.Lens as the first module, so cabal repl loads it. + exposed-modules: + Control.Lens exposed-modules: Control.Exception.Lens - Control.Lens Control.Lens.At Control.Lens.Combinators Control.Lens.Cons @@ -274,10 +250,10 @@ Control.Lens.Internal.List Control.Lens.Internal.Magma Control.Lens.Internal.Prism + Control.Lens.Internal.Profunctor Control.Lens.Internal.Review Control.Lens.Internal.Setter Control.Lens.Internal.TH - Control.Lens.Internal.Typeable Control.Lens.Internal.Zoom Control.Lens.Iso Control.Lens.Lens @@ -285,6 +261,7 @@ Control.Lens.Operators Control.Lens.Plated Control.Lens.Prism + Control.Lens.Profunctor Control.Lens.Reified Control.Lens.Review Control.Lens.Setter @@ -331,22 +308,13 @@ Control.Lens.Internal.Prelude Paths_lens - if flag(safe) - cpp-options: -DSAFE=1 - - 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 impl(ghc<7.4) - ghc-options: -fno-spec-constr-count - if impl(ghc >= 7.10) ghc-options: -fno-warn-trustworthy-safe @@ -354,10 +322,12 @@ ghc-options: -Wno-missing-pattern-synonym-signatures ghc-options: -Wno-redundant-constraints - 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 + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type hs-source-dirs: src @@ -365,15 +335,24 @@ default-language: Haskell2010 + -- future proof, whether the field will be comma separated or not. + x-docspec-extra-packages: simple-reflect + x-docspec-extra-packages: deepseq + -- Verify that Template Haskell expansion works test-suite templates type: exitcode-stdio-1.0 main-is: templates.hs - other-modules: T799 + other-modules: + T799 + T917 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type + if flag(dump-splices) ghc-options: -ddump-splices @@ -424,40 +403,17 @@ test-framework >= 0.6, test-framework-hunit >= 0.2 --- Verify the results of the examples +-- 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 - ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 - x-doctest-options: --fast - if flag(trustworthy) && impl(ghc>=7.2) - other-extensions: Trustworthy - cpp-options: -DTRUSTWORTHY=1 - - if !flag(test-doctests) - buildable: False - else - build-depends: - base, - bytestring, - containers, - directory >= 1.0, - deepseq, - doctest >= 0.11.4 && < 0.12 || >= 0.13 && < 0.17, - filepath, - generic-deriving, - lens, - mtl, - nats, - parallel, - semigroups >= 0.9, - simple-reflect >= 0.3.1, - text, - unordered-containers, - vector + build-depends: base, deepseq, simple-reflect >= 0.3.1 -- Basic benchmarks for the uniplate-style combinators benchmark plated 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 @@ -68,9 +68,7 @@ -- ** Arithmetic Exceptions , AsArithException(..) , _Overflow, _Underflow, _LossOfPrecision, _DivideByZero, _Denormal -#if MIN_VERSION_base(4,6,0) , _RatioZeroDenominator -#endif #if __GLASGOW_HASKELL__ >= 710 , pattern ArithException_ , pattern Overflow_ @@ -213,12 +211,10 @@ #endif ) -#ifdef HLINT -{-# ANN module "HLint: ignore Use Control.Exception.catch" #-} -#endif - -- $setup -- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens +-- >>> import Control.Applicative -- >>> :m + Control.Exception Control.Monad Data.List Prelude ------------------------------------------------------------------------------ @@ -632,10 +628,7 @@ Denormal_ = review _Denormal () #endif -#if MIN_VERSION_base(4,6,0) --- | Added in @base@ 4.6 in response to this libraries discussion: --- --- +-- | -- -- @ -- '_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator' @@ -654,8 +647,6 @@ #if __GLASGOW_HASKELL__ >= 710 pattern RatioZeroDenominator_ <- (has _RatioZeroDenominator -> True) where RatioZeroDenominator_ = review _RatioZeroDenominator () -#endif - #endif ---------------------------------------------------------------------------- diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -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/At.hs b/src/Control/Lens/At.hs --- a/src/Control/Lens/At.hs +++ b/src/Control/Lens/At.hs @@ -50,30 +50,42 @@ import Control.Lens.Traversal import Control.Lens.Lens import Control.Lens.Setter -import Control.Lens.Type 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.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 qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import qualified Data.IntSet as IntSet +import Data.IntSet (IntSet) +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 hiding (indexed) +import qualified Data.Vector as Vector +import qualified Data.Vector.Primitive as Prim +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Storable as Storable +import qualified Data.Vector.Unboxed as Unboxed +import Data.Vector.Unboxed (Unbox) import Data.Word +import Foreign.Storable (Storable) type family Index (s :: *) :: * type instance Index (e -> a) = e @@ -112,6 +124,9 @@ -- $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 @@ -152,18 +167,38 @@ {-# 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'. @@ -190,7 +225,7 @@ -- >>> Seq.fromList [] ^? ix 2 -- Nothing ix :: Index m -> Traversal' m (IxValue m) - 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 #-} @@ -224,8 +259,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 @@ -247,7 +282,7 @@ 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 @@ -290,21 +325,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 #-} @@ -441,7 +476,7 @@ {-# INLINE iat #-} instance At (Maybe a) where - at () f = f + at ~() f = f {-# INLINE at #-} instance At (IntMap a) where @@ -467,70 +502,79 @@ {-# 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 #-} -- | @'ix' :: 'Int' -> 'Traversal'' (a,a) a@ type instance IxValue (a,a2) = a instance (a~a2) => Ixed (a,a2) where - ix = elementOf each + 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 = elementOf each + 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 = elementOf each + 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 = elementOf each + 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 = elementOf each + 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 = elementOf each + 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 = elementOf each + 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 = elementOf each + 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 @@ -94,18 +94,18 @@ , (.@=) , (.@~) , (^#) - , ( #~ ) - , ( #%~ ) - , ( #%%~ ) - , ( #= ) - , ( #%= ) + , (#~) + , (#%~) + , (#%%~) + , (#=) + , (#%=) , (<#%~) , (<#%=) - , ( #%%= ) + , (#%%=) , (<#~) , (<#=) , (...) - , ( # ) + , (#) , (%~) , (.~) , (?~) 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 @@ -50,12 +50,12 @@ import Control.Lens.Review import Control.Lens.Tuple import Control.Lens.Type -import Control.Lens.Internal.Coerce 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) @@ -70,13 +70,12 @@ import Control.Applicative (ZipList(..)) import Prelude -#ifdef HLINT -{-# ANN module "HLint: ignore Eta reduce" #-} -#endif - -- $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 @@ -125,7 +124,7 @@ instance Cons (ZipList a) (ZipList b) a b where _Cons = withPrism listCons $ \listReview listPreview -> - prism (coerce' listReview) (coerce' listPreview) where + prism (coerce listReview) (coerce listPreview) where listCons :: Prism [a] [b] (a, [a]) (b, [b]) listCons = _Cons @@ -359,7 +358,7 @@ instance Snoc (ZipList a) (ZipList b) a b where _Snoc = withPrism listSnoc $ \listReview listPreview -> - prism (coerce' listReview) (coerce' listPreview) where + prism (coerce listReview) (coerce listPreview) where listSnoc :: Prism [a] [b] ([a], a) ([b], b) listSnoc = _Snoc @@ -545,5 +544,5 @@ -- >>> 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 #-} 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 @@ -35,16 +35,16 @@ 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.HashMap.Lazy as HashMap -import Data.IntMap as IntMap -import Data.Map as Map -import Data.Sequence as Seq +import Data.HashMap.Lazy (HashMap) +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Sequence (Seq) import Data.Text.Lens (text) -import Data.Text as StrictT -import Data.Text.Lazy as LazyT +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 @@ -55,6 +55,8 @@ import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import Data.Word +import qualified Data.Strict as S +import Data.These (These (..)) -- $setup -- >>> :set -XNoOverloadedStrings @@ -221,3 +223,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 @@ -37,26 +37,37 @@ 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 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.Map as Map +import qualified Data.Map as Map +import Data.Map (Map) import Data.Maybe import qualified 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.Set as Set +import Data.Set (Set) +import qualified Data.Text as StrictT +import qualified Data.Text.Lazy as LazyT +import qualified Data.Vector as Vector +import qualified Data.Vector.Unboxed as Unboxed +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Storable as Storable +import Foreign.Storable (Storable) #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) import GHC.Event #endif + +-- $setup +-- >>> import Control.Lens class AsEmpty a where -- | 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 @@ -3,11 +3,10 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-} +{-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -54,11 +53,6 @@ import Data.Kind (Type) #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use id" #-} -{-# ANN module "HLint: ignore Eta reduce" #-} -#endif - -- $setup -- >>> import Control.Lens @@ -73,11 +67,7 @@ Identical :: Identical a b a b -- | When you see this as an argument to a function, it expects an 'Equality'. -#if __GLASGOW_HASKELL__ >= 706 -type AnEquality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = Identical a (Proxy b) a (Proxy b) -> Identical a (Proxy b) s (Proxy t) -#else type AnEquality s t a b = Identical a (Proxy b) a (Proxy b) -> Identical a (Proxy b) s (Proxy t) -#endif -- | A 'Simple' 'AnEquality'. type AnEquality' s a = AnEquality s s a a @@ -101,10 +91,8 @@ -- | We can use 'Equality' to do substitution into anything. #if __GLASGOW_HASKELL__ >= 800 mapEq :: forall k1 k2 (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> Type) . AnEquality s t a b -> f s -> f a -#elif __GLASGOW_HASKELL__ >= 706 -mapEq :: forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a #else -mapEq :: AnEquality s t a b -> f s -> f a +mapEq :: forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a #endif mapEq l r = substEq l r {-# INLINE mapEq #-} 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 @@ -175,6 +175,7 @@ -- >>> 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) @@ -187,13 +188,6 @@ -- >>> 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" #-} -{-# ANN module "HLint: ignore Use fmap" #-} -#endif - infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! -------------------------- @@ -306,7 +300,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 @@ -322,7 +316,7 @@ -- 'iterated' :: (a -> a) -> 'Fold1' a a -- @ iterated :: Apply f => (a -> a) -> LensLike' f a a -iterated f g a0 = go a0 where +iterated f g = go where go a = g a .> go (f a) {-# INLINE iterated #-} 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 @@ -4,11 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE NoPolyKinds #-} -{-# LANGUAGE NoDataKinds #-} -#endif - -- Disable the warnings generated by '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. @@ -98,7 +93,9 @@ -- $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 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 @@ -1,12 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- vector, hashable @@ -39,9 +34,12 @@ , 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 @@ -78,53 +77,38 @@ import Prelude () -import Control.Applicative.Backwards -import Control.Comonad.Cofree -import Control.Comonad.Trans.Traced -import Control.Monad (void, liftM) -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Free +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Traversable.WithIndex + import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal.Fold import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude -import Control.Lens.Internal.Level -import Control.Lens.Internal.Magma import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type -import Data.Array (Array) -import qualified Data.Array as Array -import Data.Foldable -import Data.Functor.Constant (Constant (..)) -import Data.Functor.Product -import Data.Functor.Reverse -import Data.Functor.Sum -import Data.HashMap.Lazy as HashMap -import Data.IntMap as IntMap -import Data.Ix (Ix) -import Data.Map as Map -import Data.Monoid hiding (Sum, Product) import Data.Reflection -import Data.Sequence hiding ((:<), index) -import Data.Tree -import Data.Tuple (swap) + +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 GHC.Generics -#ifdef HLINT -{-# ANN module "HLint: ignore Use fmap" #-} -#endif +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. -- @@ -215,498 +199,46 @@ -- 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 - default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b - imap = iover itraversed - {-# INLINE imap #-} - - -- | 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' '.' 'asIndex'@ is a fold over the keys of a 'FoldableWithIndex'. - -- - -- >>> Data.Map.fromList [(2, "hello"), (1, "world")]^..ifolded.asIndex - -- [1,2] - ifolded :: IndexedFold i (f a) a - ifolded = conjoined folded $ \f -> phantom . 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 = void . getTraversed #. ifoldMap (\i -> Traversed #. 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 = liftM skip . getSequenced #. ifoldMap (\i -> Sequenced #. 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' 'snd' '.' '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' ≡ 'itraverseOf' 'itraversed' - -- @ - itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b) -#ifndef HLINT - default itraverse :: (i ~ Int, Applicative f) => (i -> 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 Void (Const e) where - imap _ (Const a) = Const a - {-# INLINE imap #-} - -instance FoldableWithIndex Void (Const e) where - ifoldMap _ _ = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex Void (Const e) where - itraverse _ (Const a) = pure (Const a) - {-# INLINE itraverse #-} - -instance FunctorWithIndex Void (Constant e) where - imap _ (Constant a) = Constant a - {-# INLINE imap #-} - -instance FoldableWithIndex Void (Constant e) where - ifoldMap _ _ = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex Void (Constant e) where - itraverse _ (Constant a) = pure (Constant 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 - itraversed = traversed - {-# INLINE itraversed #-} - --- | Same instance as for @[]@. -instance FunctorWithIndex Int ZipList -instance FoldableWithIndex Int ZipList -instance TraversableWithIndex Int ZipList where - itraversed = traversed - {-# INLINE itraversed #-} - -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 where - imap = mapWithIndex -instance FoldableWithIndex Int Seq where -#if MIN_VERSION_containers(0,5,8) - ifoldMap = foldMapWithIndex -#else - ifoldMap f = Data.Foldable.fold . mapWithIndex f -#endif - ifoldr = foldrWithIndex - ifoldl f = foldlWithIndex (flip f) - {-# INLINE ifoldl #-} -instance TraversableWithIndex Int Seq where -#if MIN_VERSION_containers(0,5,8) - itraverse = traverseWithIndex -#else - itraverse f = sequenceA . mapWithIndex f -#endif - -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 - itraversed = traversed - {-# INLINE itraversed #-} - -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 [0] 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; + #-} {-# RULES "itraversed -> mapIntMap" itraversed = sets IntMap.map :: ASetter (IntMap a) (IntMap b) a b; @@ -715,16 +247,6 @@ "itraversed -> ifoldrIntMap" itraversed = ifoldring IntMap.foldrWithKey :: IndexedGetting Int (Endo r) (IntMap a) a; #-} -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 [0] itraverse #-} - {-# 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; @@ -732,12 +254,6 @@ "itraversed -> ifoldrMap" itraversed = ifoldring Map.foldrWithKey :: IndexedGetting k (Endo r) (Map k a) a; #-} -instance FunctorWithIndex k (HashMap k) -instance FoldableWithIndex k (HashMap k) -instance TraversableWithIndex k (HashMap k) where - itraverse = HashMap.traverseWithKey - {-# INLINE [0] 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; @@ -745,290 +261,19 @@ "itraversed -> ifoldrHashMap" itraversed = ifoldring HashMap.foldrWithKey :: IndexedGetting k (Endo r) (HashMap k a) a; #-} -instance FunctorWithIndex r ((->) r) where - imap f g x = f x (g x) - {-# INLINE imap #-} - -instance FunctorWithIndex i (Level i) where - imap f = go where - go (Two n l r) = Two n (go l) (go r) - go (One i a) = One i (f i a) - go Zero = Zero - {-# INLINE imap #-} - -instance FoldableWithIndex i (Level i) where - ifoldMap f = go where - go (Two _ l r) = go l `mappend` go r - go (One i a) = f i a - go Zero = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i (Level i) where - itraverse f = go where - go (Two n l r) = Two n <$> go l <*> go r - go (One i a) = One i <$> f i a - go Zero = pure Zero - {-# INLINE itraverse #-} - -instance FunctorWithIndex i (Magma i t b) where - imap f (MagmaAp x y) = MagmaAp (imap f x) (imap f y) - imap _ (MagmaPure x) = MagmaPure x - imap f (MagmaFmap xy x) = MagmaFmap xy (imap f x) - imap f (Magma i a) = Magma i (f i a) - {-# INLINE imap #-} - -instance FoldableWithIndex i (Magma i t b) where - ifoldMap f (MagmaAp x y) = ifoldMap f x `mappend` ifoldMap f y - ifoldMap _ MagmaPure{} = mempty - ifoldMap f (MagmaFmap _ x) = ifoldMap f x - ifoldMap f (Magma i a) = f i a - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i (Magma i t b) where - itraverse f (MagmaAp x y) = MagmaAp <$> itraverse f x <*> itraverse f y - itraverse _ (MagmaPure x) = pure (MagmaPure x) - itraverse f (MagmaFmap xy x) = MagmaFmap xy <$> itraverse f x - itraverse f (Magma i a) = Magma i <$> f i a - {-# INLINE itraverse #-} - -instance FunctorWithIndex i f => FunctorWithIndex [i] (Free f) where - imap f (Pure a) = Pure $ f [] a - imap f (Free s) = Free $ imap (\i -> imap (f . (:) i)) s - {-# INLINE imap #-} - -instance FoldableWithIndex i f => FoldableWithIndex [i] (Free f) where - ifoldMap f (Pure a) = f [] a - ifoldMap f (Free s) = ifoldMap (\i -> ifoldMap (f . (:) i)) s - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i f => TraversableWithIndex [i] (Free f) where - itraverse f (Pure a) = Pure <$> f [] a - itraverse f (Free s) = Free <$> itraverse (\i -> itraverse (f . (:) i)) s - {-# INLINE itraverse #-} - -instance Ix i => FunctorWithIndex i (Array i) where - imap f arr = Array.listArray (Array.bounds arr) . fmap (uncurry f) $ Array.assocs arr - {-# INLINE imap #-} - -instance Ix i => FoldableWithIndex i (Array i) where - ifoldMap f = foldMap (uncurry f) . Array.assocs - {-# INLINE ifoldMap #-} - -instance Ix i => TraversableWithIndex i (Array i) where - itraverse f arr = Array.listArray (Array.bounds arr) <$> traverse (uncurry f) (Array.assocs arr) - {-# INLINE itraverse #-} - -instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where - imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as - {-# INLINE imap #-} - -instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where - ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where - itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as - {-# INLINE itraverse #-} - -instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (Compose f g) where - imap f (Compose fg) = Compose $ imap (\k -> imap (f . (,) k)) fg - {-# INLINE imap #-} - -instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (Compose f g) where - ifoldMap f (Compose fg) = ifoldMap (\k -> ifoldMap (f . (,) k)) fg - {-# INLINE ifoldMap #-} - -instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (Compose f g) where - itraverse f (Compose fg) = Compose <$> itraverse (\k -> itraverse (f . (,) k)) fg - {-# INLINE itraverse #-} - -instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Sum f g) where - imap q (InL fa) = InL (imap (q . Left) fa) - imap q (InR ga) = InR (imap (q . Right) ga) - {-# INLINE imap #-} - -instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Sum f g) where - ifoldMap q (InL fa) = ifoldMap (q . Left) fa - ifoldMap q (InR ga) = ifoldMap (q . Right) ga - {-# INLINE ifoldMap #-} - -instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Sum f g) where - itraverse q (InL fa) = InL <$> itraverse (q . Left) fa - itraverse q (InR ga) = InR <$> itraverse (q . Right) ga - {-# INLINE itraverse #-} - -instance FunctorWithIndex i m => FunctorWithIndex i (IdentityT m) where - imap f (IdentityT m) = IdentityT $ imap f m - {-# INLINE imap #-} - -instance FoldableWithIndex i m => FoldableWithIndex i (IdentityT m) where - ifoldMap f (IdentityT m) = ifoldMap f m - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i m => TraversableWithIndex i (IdentityT m) where - itraverse f (IdentityT m) = IdentityT <$> itraverse f m - {-# INLINE itraverse #-} - -instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Product f g) where - imap f (Pair a b) = Pair (imap (f . Left) a) (imap (f . Right) b) - {-# INLINE imap #-} - -instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Product f g) where - ifoldMap f (Pair a b) = ifoldMap (f . Left) a `mappend` ifoldMap (f . Right) b - {-# INLINE ifoldMap #-} - -instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Product f g) where - itraverse f (Pair a b) = Pair <$> itraverse (f . Left) a <*> itraverse (f . Right) b - {-# INLINE itraverse #-} - -instance FunctorWithIndex i m => FunctorWithIndex (e, i) (ReaderT e m) where - imap f (ReaderT m) = ReaderT $ \k -> imap (f . (,) k) (m k) - {-# INLINE imap #-} - -instance FunctorWithIndex i w => FunctorWithIndex (s, i) (TracedT s w) where - imap f (TracedT w) = TracedT $ imap (\k' g k -> f (k, k') (g k)) w - {-# INLINE imap #-} - -instance FunctorWithIndex [Int] Tree where - imap f (Node a as) = Node (f [] a) $ imap (\i -> imap (f . (:) i)) as - {-# INLINE imap #-} - -instance FoldableWithIndex [Int] Tree where - ifoldMap f (Node a as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex [Int] Tree where - itraverse f (Node a as) = Node <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as - {-# INLINE itraverse #-} - -instance FunctorWithIndex Void Proxy where - imap _ Proxy = Proxy - {-# INLINE imap #-} - -instance FoldableWithIndex Void Proxy where - ifoldMap _ _ = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex Void Proxy where - itraverse _ _ = pure Proxy - {-# INLINE itraverse #-} - -instance FunctorWithIndex () (Tagged a) where - imap f (Tagged a) = Tagged (f () a) - {-# INLINE imap #-} - -instance FoldableWithIndex () (Tagged a) where - ifoldMap f (Tagged a) = f () a - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex () (Tagged a) where - itraverse f (Tagged a) = Tagged <$> f () a - {-# INLINE itraverse #-} - -instance FunctorWithIndex Void V1 where - imap _ v = v `seq` undefined - {-# INLINE imap #-} - -instance FoldableWithIndex Void V1 where - ifoldMap _ v = v `seq` undefined - -instance TraversableWithIndex Void V1 where - itraverse _ v = v `seq` undefined - -instance FunctorWithIndex Void U1 where - imap _ U1 = U1 - {-# INLINE imap #-} - -instance FoldableWithIndex Void U1 where - ifoldMap _ _ = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex Void U1 where - itraverse _ U1 = pure U1 - {-# INLINE itraverse #-} - -instance FunctorWithIndex () Par1 where - imap f = fmap (f ()) - {-# INLINE imap #-} - -instance FoldableWithIndex () Par1 where - ifoldMap f (Par1 a) = f () a - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex () Par1 where - itraverse f (Par1 a) = Par1 <$> f () a - {-# INLINE itraverse #-} - -instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (f :.: g) where - imap q (Comp1 fga) = Comp1 (imap (\k -> imap (q . (,) k)) fga) - {-# INLINE imap #-} - -instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (f :.: g) where - ifoldMap q (Comp1 fga) = ifoldMap (\k -> ifoldMap (q . (,) k)) fga - {-# INLINE ifoldMap #-} - -instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (f :.: g) where - itraverse q (Comp1 fga) = Comp1 <$> itraverse (\k -> itraverse (q . (,) k)) fga - {-# INLINE itraverse #-} - -instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :*: g) where - imap q (fa :*: ga) = imap (q . Left) fa :*: imap (q . Right) ga - {-# INLINE imap #-} - -instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :*: g) where - ifoldMap q (fa :*: ga) = ifoldMap (q . Left) fa `mappend` ifoldMap (q . Right) ga - {-# INLINE ifoldMap #-} - -instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :*: g) where - itraverse q (fa :*: ga) = (:*:) <$> itraverse (q . Left) fa <*> itraverse (q . Right) ga - {-# INLINE itraverse #-} - -instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :+: g) where - imap q (L1 fa) = L1 (imap (q . Left) fa) - imap q (R1 ga) = R1 (imap (q . Right) ga) - {-# INLINE imap #-} - -instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :+: g) where - ifoldMap q (L1 fa) = ifoldMap (q . Left) fa - ifoldMap q (R1 ga) = ifoldMap (q . Right) ga - {-# INLINE ifoldMap #-} - -instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :+: g) where - itraverse q (L1 fa) = L1 <$> itraverse (q . Left) fa - itraverse q (R1 ga) = R1 <$> itraverse (q . Right) ga - {-# INLINE itraverse #-} - -instance FunctorWithIndex i f => FunctorWithIndex i (Rec1 f) where - imap q (Rec1 f) = Rec1 (imap q f) - {-# INLINE imap #-} - -instance FoldableWithIndex i f => FoldableWithIndex i (Rec1 f) where - ifoldMap q (Rec1 f) = ifoldMap q f - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex i f => TraversableWithIndex i (Rec1 f) where - itraverse q (Rec1 f) = Rec1 <$> itraverse q f - {-# INLINE itraverse #-} - -instance FunctorWithIndex Void (K1 i c) where - imap _ (K1 c) = K1 c - {-# INLINE imap #-} - -instance FoldableWithIndex Void (K1 i c) where - ifoldMap _ _ = mempty - {-# INLINE ifoldMap #-} - -instance TraversableWithIndex Void (K1 i c) where - itraverse _ (K1 a) = pure (K1 a) - {-# INLINE itraverse #-} - -------------------------------------------------------------------------------- --- 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 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,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal @@ -41,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/Bazaar.hs b/src/Control/Lens/Internal/Bazaar.hs --- a/src/Control/Lens/Internal/Bazaar.hs +++ b/src/Control/Lens/Internal/Bazaar.hs @@ -3,9 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif #if __GLASGOW_HASKELL__ >= 711 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif @@ -148,9 +146,7 @@ -- 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 type role BazaarT representational nominal nominal nominal nominal -#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. -- @@ -326,9 +322,7 @@ -- 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 type role BazaarT1 representational nominal nominal nominal nominal -#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. -- 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 @@ -23,10 +23,8 @@ -- Haskell Platforms and to improve constant and asymptotic factors in our performance. ---------------------------------------------------------------------------- module Control.Lens.Internal.ByteString - ( unpackStrict, traversedStrictTree - , unpackStrict8, traversedStrictTree8 - , unpackLazy, traversedLazy - , unpackLazy8, traversedLazy8 + ( traversedStrictTree, traversedStrictTree8 + , traversedLazy, traversedLazy8 ) where import Prelude () @@ -54,9 +52,6 @@ #else import Foreign.ForeignPtr.Safe #endif -#if !MIN_VERSION_bytestring(0,10,4) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -#endif import GHC.Base (unsafeChr) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) import GHC.IO (unsafeDupablePerformIO) @@ -128,16 +123,11 @@ ifoldrB8 f z xs = B8.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrB8 #-} --- | Unpack a lazy 'Bytestring' -unpackLazy :: BL.ByteString -> [Word8] -unpackLazy = BL.unpack -{-# INLINE unpackLazy #-} - -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' traversedLazy :: IndexedTraversal' Int64 BL.ByteString Word8 -traversedLazy pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0 +traversedLazy pafb = \lbs -> BL.foldrChunks go (\_ -> pure BL.empty) lbs 0 where - go c fcs acc = BL.append . fromStrict + go c fcs acc = BL.append . BL.fromStrict <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree pafb c <*> fcs acc' where @@ -164,16 +154,11 @@ ifoldrBL f z xs = BL.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrBL #-} --- | Unpack a lazy 'BL.ByteString' pretending the bytes are chars. -unpackLazy8 :: BL.ByteString -> String -unpackLazy8 = BL8.unpack -{-# INLINE unpackLazy8 #-} - -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' pretending the bytes are chars. traversedLazy8 :: IndexedTraversal' Int64 BL.ByteString Char -traversedLazy8 pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0 +traversedLazy8 pafb = \lbs -> BL.foldrChunks go (\_ -> pure BL.empty) lbs 0 where - go c fcs acc = BL.append . fromStrict + go c fcs acc = BL.append . BL.fromStrict <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree8 pafb c <*> fcs acc' where @@ -204,22 +189,6 @@ -- ByteString guts ------------------------------------------------------------------------------ -fromStrict :: B.ByteString -> BL.ByteString -#if MIN_VERSION_bytestring(0,10,0) -fromStrict = BL.fromStrict -#else -fromStrict = \x -> BL.fromChunks [x] -#endif -{-# INLINE fromStrict #-} - -foldrChunks :: (B.ByteString -> r -> r) -> r -> BL.ByteString -> r -#if MIN_VERSION_bytestring(0,10,0) -foldrChunks = BL.foldrChunks -#else -foldrChunks f z b = foldr f z (BL.toChunks b) -#endif -{-# INLINE foldrChunks #-} - -- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. w2c :: Word8 -> Char w2c = unsafeChr . fromIntegral @@ -232,43 +201,6 @@ c2w = fromIntegral . ord {-# INLINE c2w #-} --- | Unpack a strict 'B.Bytestring' -unpackStrict :: B.ByteString -> [Word8] -#if MIN_VERSION_bytestring(0,10,4) -unpackStrict = B.unpack -#else -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 -#endif -{-# INLINE unpackStrict #-} - --- | Unpack a strict 'B.Bytestring', pretending the bytes are chars. -unpackStrict8 :: B.ByteString -> String -#if MIN_VERSION_bytestring(0,10,4) -unpackStrict8 = B8.unpack -#else -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 -#endif -{-# 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 @@ -282,5 +214,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/Coerce.hs b/src/Control/Lens/Internal/Coerce.hs --- a/src/Control/Lens/Internal/Coerce.hs +++ b/src/Control/Lens/Internal/Coerce.hs @@ -1,13 +1,7 @@ {-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 708 -#define USE_COERCE {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -#else -{-# LANGUAGE Unsafe #-} -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2016 Edward Kmett and Eric Mertens @@ -16,9 +10,8 @@ -- Stability : experimental -- Portability : non-portable -- --- This module provides a shim around 'coerce' that defaults to 'unsafeCoerce' --- on GHC < 7.8. It also exposes a type-restricted version of '(#.)' that --- works around a bizarre GHC 7.10–specific bug. +-- This module provides a shim around 'coerce'. +-- We need to work around a GHC 7.8-specific 'Coercible' solver bug(s). ----------------------------------------------------------------------------- module Control.Lens.Internal.Coerce ( coerce @@ -27,30 +20,16 @@ ) where import Data.Profunctor.Unsafe - -#ifdef USE_COERCE - import Data.Coerce coerce' :: forall a b. Coercible a b => b -> a +#if __GLASGOW_HASKELL__ <710 coerce' = coerce (id :: a -> a) -{-# INLINE coerce' #-} - -(#..) :: (Profunctor p, Coercible c b) => (b -> c) -> p a b -> p a c -(#..) = (#.) -{-# INLINE (#..) #-} - #else - -import Unsafe.Coerce - -coerce, coerce' :: a -> b -coerce = unsafeCoerce -coerce' = unsafeCoerce -{-# INLINE coerce #-} +coerce' = coerce +#endif {-# INLINE coerce' #-} -(#..) :: Profunctor p => (b -> c) -> p a b -> p a c +(#..) :: (Profunctor p, Coercible c b) => (b -> c) -> p a b -> p a c (#..) = (#.) {-# INLINE (#..) #-} -#endif 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,12 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif ----------------------------------------------------------------------------- -- | @@ -63,9 +60,8 @@ -- "Parameterized Notions of Computation" -- and that construction is dualized here. class IndexedFunctor w => IndexedComonad w where -#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL iextract, (iduplicate | iextend) #-} -#endif + -- | extract from an indexed comonadic value when the indices match. iextract :: w a a t -> t @@ -285,11 +281,9 @@ -- 'Control.Lens.Getter.Getter'. newtype PretextT p (g :: * -> *) 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 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 @@ -40,16 +40,19 @@ import Data.Functor.Plus import Data.Functor.Reverse +-- $setup +-- >>> import Control.Applicative (empty) + -- | A Banker's deque based on Chris Okasaki's \"Purely Functional Data Structures\" data Deque a = BD !Int [a] !Int [a] deriving Show -- | /O(1)/. Determine if a 'Deque' is 'empty'. -- --- >>> 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 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 @@ -5,12 +5,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} -#endif #include "lens-common.h" @@ -40,11 +37,6 @@ 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 ------------------------------------------------------------------------------ @@ -138,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) ------------------------------------------------------------------------------ @@ -167,26 +159,10 @@ -- | 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 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 -handlingTyCon = mkTyCon3 "lens" "Control.Lens.Internal.Exception" "Handling" -{-# 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 ..." @@ -194,11 +170,7 @@ instance ( Reifies s (SomeException -> Maybe a) , Typeable a, Typeable s -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 , Typeable m -#else - , Typeable1 m -#endif ) => Exception (Handling a (s :: *) m) where toException _ = SomeException HandlingException diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs --- a/src/Control/Lens/Internal/FieldTH.hs +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -48,6 +48,7 @@ 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 (isJust,maybeToList) import Data.List (nub, findIndices) import Data.Either (partitionEithers) @@ -84,7 +85,7 @@ let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons let defCons = over normFieldLabels (expandName allFields) fieldCons allDefs = setOf (normFieldLabels . folded) defCons - T.sequenceA (fromSet (buildScaffold rules s defCons) allDefs) + T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of @@ -94,9 +95,9 @@ return (concat decss) where - tyName = D.datatypeName info - s = D.datatypeType info - cons = D.datatypeCons info + 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 @@ -241,7 +242,7 @@ let s' = applyTypeSubst subA s -- compute possible type changes - sub <- T.sequenceA (fromSet (newName . nameBase) unfixedTypeVars) + sub <- T.sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars) let (t,b) = over both (substTypeVars sub) (s',a) return (s',t,a,b) @@ -319,12 +320,13 @@ let ss = map (stabToS . view (_2 . _2)) defs (sub,s') <- unifyTypes (s : ss) c <- newName "c" - let vars = toListOf typeVars s' + let vars = D.freeVariablesWellScoped [s'] + varNames = map D.tvName vars fd | null vars = [] - | otherwise = [FunDep [c] vars] + | otherwise = [FunDep [c] varNames] - classD (cxt[]) className (map PlainTV (c:vars)) fd + classD (cxt[]) className (D.plainTV c:vars) fd $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s'])) : concat [ [sigD defName (return ty) @@ -333,7 +335,7 @@ inlinePragma defName | (TopName defName, (_, stab, _)) <- defs , let body = appsE [varE composeValName, varE methodName, varE defName] - , let ty = quantifyType' (Set.fromList (c:vars)) + , let ty = quantifyType' (Set.fromList (c:varNames)) (stabToContext stab) $ stabToOptic stab `conAppsT` [VarT c, applyTypeSubst sub (stabToA stab)] @@ -355,8 +357,8 @@ : map return (concat methodss) where - instanceHead = className `conAppsT` (s : map VarT vars) - vars = toListOf typeVars s + instanceHead = className `conAppsT` (s : map tvbToType vars) + vars = D.freeVariablesWellScoped [s] rules' = rules { _generateSigs = False , _generateClasses = False } @@ -367,7 +369,7 @@ makeFieldClass :: OpticStab -> Name -> Name -> DecQ makeFieldClass defType className methodName = - classD (cxt []) className [PlainTV s, PlainTV a] [FunDep [s] [a]] + classD (cxt []) className [D.plainTV s, D.plainTV a] [FunDep [s] [a]] [sigD methodName (return methodType)] where methodType = quantifyType' (Set.fromList [s,a]) @@ -398,9 +400,6 @@ #if !(MIN_VERSION_template_haskell(2,11,0)) _OpenTypeFamilyD = _FamilyD . _1 . _TypeFam #endif -#if !(MIN_VERSION_template_haskell(2,9,0)) - _ClosedTypeFamilyD = ignored -#endif pickInstanceDec hasFamilies | hasFamilies = do @@ -557,18 +556,13 @@ -- | 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 -> TyVarBndr -> Q TyVarBndr -limitedSubst sub (PlainTV n) - | Just r <- Map.lookup n sub = - case r of - VarT m -> limitedSubst sub (PlainTV m) - _ -> fail "Unable to unify exotic higher-rank type" -limitedSubst sub (KindedTV n k) - | Just r <- Map.lookup n sub = +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 (KindedTV m k) + VarT m -> limitedSubst sub (D.mapTVName (const m) tv) _ -> fail "Unable to unify exotic higher-rank type" -limitedSubst _ tv = return tv + | otherwise = return tv -- | Apply a substitution to a type. This is used after unifying @@ -627,23 +621,3 @@ addFieldClassName :: Name -> HasFieldClasses () addFieldClassName n = modify $ Set.insert n - ------------------------------------------------------------------------- --- Miscellaneous utility functions ------------------------------------------------------------------------- - - --- | 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 = map PlainTV - $ filter (`Set.notMember` exclude) - $ nub -- stable order - $ toListOf typeVars t 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 @@ -23,8 +23,6 @@ , Traversed(..) , TraversedF(..) , Sequenced(..) - , Max(..), getMax - , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost , ReifiedMonoid(..) @@ -42,10 +40,6 @@ import qualified Data.List.NonEmpty as NonEmpty -#ifdef HLINT -{-# ANN module "HLint: ignore Avoid lambda" #-} -#endif - ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------ @@ -122,60 +116,6 @@ {-# INLINE mempty #-} Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) {-# INLINE mappend #-} - ------------------------------------------------------------------------------- --- Min ------------------------------------------------------------------------------- - --- | Used for 'Control.Lens.Fold.minimumOf'. -data Min a = NoMin | Min a - -instance Ord a => Semigroup (Min a) where - NoMin <> m = m - m <> NoMin = m - Min a <> Min b = Min (min a b) - {-# INLINE (<>) #-} - -instance Ord a => Monoid (Min a) where - mempty = NoMin - {-# INLINE mempty #-} - mappend NoMin m = m - mappend m NoMin = m - mappend (Min a) (Min b) = Min (min a b) - {-# INLINE mappend #-} - --- | Obtain the minimum. -getMin :: Min a -> Maybe a -getMin NoMin = Nothing -getMin (Min a) = Just a -{-# INLINE getMin #-} - ------------------------------------------------------------------------------- --- Max ------------------------------------------------------------------------------- - --- | Used for 'Control.Lens.Fold.maximumOf'. -data Max a = NoMax | Max a - -instance Ord a => Semigroup (Max a) where - NoMax <> m = m - m <> NoMax = m - Max a <> Max b = Max (max a b) - {-# INLINE (<>) #-} - -instance Ord a => Monoid (Max a) where - mempty = NoMax - {-# INLINE mempty #-} - mappend NoMax m = m - mappend m NoMax = m - mappend (Max a) (Max b) = Max (max a b) - {-# INLINE mappend #-} - --- | Obtain the maximum. -getMax :: Max a -> Maybe a -getMax NoMax = Nothing -getMax (Max a) = Just a -{-# INLINE getMax #-} ------------------------------------------------------------------------------ -- NonEmptyDList 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 @@ -5,10 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | @@ -52,14 +49,13 @@ import Data.Int import Data.Profunctor.Closed import Data.Profunctor.Rep -#ifndef SAFE import Control.Lens.Internal.Coerce -#endif -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens +-- >>> import Data.Semigroup (Semigroup (..)) -- ------------------------------------------------------------------------------ -- Conjoined @@ -154,12 +150,10 @@ {-# INLINE lmap #-} rmap bc iab = Indexed $ \i -> bc . runIndexed iab i {-# INLINE rmap #-} -#ifndef SAFE - ( .# ) ibc _ = coerce ibc - {-# INLINE ( .# ) #-} - ( #. ) _ = coerce' - {-# INLINE ( #. ) #-} -#endif + (.#) ibc _ = coerce ibc + {-# INLINE (.#) #-} + (#.) _ = coerce' + {-# INLINE (#.) #-} instance Closed (Indexed i) where closed (Indexed iab) = Indexed $ \i xa x -> iab i (xa x) 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -18,21 +19,24 @@ ) where import Data.Profunctor -#ifndef SAFE import Data.Profunctor.Unsafe import Control.Lens.Internal.Coerce -#endif -import Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB -import Data.List.NonEmpty as NonEmpty -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.ByteString as StrictB +import qualified Data.ByteString.Lazy as LazyB +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as StrictT +import qualified Data.Text.Lazy as LazyT +import qualified Data.Vector as Vector +import qualified Data.Vector.Primitive as Prim +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Storable as Storable +import qualified Data.Vector.Unboxed as Unbox +import Data.Vector.Unboxed (Unbox) +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) +import Foreign.Storable (Storable) + ------------------------------------------------------------------------------ -- Isomorphism: Exchange ------------------------------------------------------------------------------ @@ -52,12 +56,9 @@ {-# INLINE lmap #-} rmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE rmap #-} -#ifndef SAFE - ( #. ) _ = coerce' - {-# INLINE ( #. ) #-} - ( .# ) p _ = coerce p - {-# INLINE ( .# ) #-} -#endif + (#.) _ = coerce' + {-# INLINE (#.) #-} + (.#) p _ = coerce p ------------------------------------------------------------------------------ -- Reversible 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 @@ -30,6 +30,9 @@ import Control.Lens.Internal.Prelude import Data.Functor.Apply +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Levels @@ -85,6 +88,27 @@ go (One i a) = One i <$> f a go Zero = pure Zero {-# INLINE traverse #-} + +instance FunctorWithIndex i (Level i) where + imap f = go where + go (Two n l r) = Two n (go l) (go r) + go (One i a) = One i (f i a) + go Zero = Zero + {-# INLINE imap #-} + +instance FoldableWithIndex i (Level i) where + ifoldMap f = go where + go (Two _ l r) = go l `mappend` go r + go (One i a) = f i a + go Zero = mempty + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i (Level i) where + itraverse f = go where + go (Two n l r) = Two n <$> go l <*> go r + go (One i a) = One i <$> f i a + go Zero = pure Zero + {-# INLINE itraverse #-} ------------------------------------------------------------------------------ -- Generating Levels diff --git a/src/Control/Lens/Internal/List.hs b/src/Control/Lens/Internal/List.hs --- a/src/Control/Lens/Internal/List.hs +++ b/src/Control/Lens/Internal/List.hs @@ -18,10 +18,6 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -#ifdef HLINT -{-# ANN module "HLint: ignore Redundant bracket" #-} -#endif - -- | Return the the subset of given ordinals within a given bound -- and in order of the first occurrence seen. -- 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 @@ -6,9 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma @@ -42,6 +40,9 @@ import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Data.Functor.Apply +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Magma @@ -55,10 +56,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) @@ -78,6 +77,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 @@ -210,9 +230,7 @@ -- 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 type role TakingWhile nominal nominal nominal nominal nominal -#endif -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a) diff --git a/src/Control/Lens/Internal/Prelude.hs b/src/Control/Lens/Internal/Prelude.hs --- a/src/Control/Lens/Internal/Prelude.hs +++ b/src/Control/Lens/Internal/Prelude.hs @@ -109,6 +109,10 @@ 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 () + -- $setup -- >>> import Control.Lens -- >>> import Control.Monad.State 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,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Prism @@ -17,10 +17,7 @@ import Prelude () import Control.Lens.Internal.Prelude - -#ifndef SAFE import Control.Lens.Internal.Coerce -#endif ------------------------------------------------------------------------------ -- Prism: Market @@ -45,12 +42,10 @@ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE rmap #-} -#ifndef SAFE - ( #. ) _ = coerce' - {-# INLINE ( #. ) #-} - ( .# ) p _ = coerce 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 --- a/src/Control/Lens/Internal/PrismTH.hs +++ b/src/Control/Lens/Internal/PrismTH.hs @@ -23,21 +23,22 @@ ) where import Control.Applicative -import Control.Lens.Fold 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 Data.List +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. @@ -136,7 +137,7 @@ let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info - makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls + makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given 'Dec' @@ -146,7 +147,7 @@ let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info - makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls + makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given type, normalized constructors, and @@ -165,7 +166,7 @@ stab <- computeOpticType t cons con let n = prismName conName sequenceA - ( [ sigD n (close (stabToType stab)) + ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab))) , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] ] ++ inlinePragma n @@ -196,24 +197,22 @@ stabSimple :: Stab -> Bool stabSimple (Stab _ _ s t a b) = s == t && a == b -stabToType :: Stab -> Type -stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $ - case ty of - PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b] - | otherwise -> prismTypeName `conAppsT` [s,t,a,b] - ReviewType -> reviewTypeName `conAppsT` [t,b] - +stabToType :: Set Name -> Stab -> Type +stabToType clsTVBNames stab@(Stab cx ty s t a b) = + quantifyType' clsTVBNames cx stabTy where - vs = map PlainTV - $ nub -- stable order - $ toListOf typeVars cx + 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' = delete con cons + 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) @@ -235,7 +234,7 @@ computePrismType t cx cons con = do let ts = view nconTypes con unbound = setOf typeVars t Set.\\ setOf typeVars cons - sub <- sequenceA (fromSet (newName . nameBase) unbound) + sub <- sequenceA (Map.fromSet (newName . nameBase) unbound) b <- toTupleT (map return ts) a <- toTupleT (map return (substTypeVars sub ts)) let s = substTypeVars sub t @@ -244,18 +243,16 @@ computeIsoType :: Type -> [Type] -> TypeQ computeIsoType t' fields = - do sub <- sequenceA (fromSet (newName . nameBase) (setOf typeVars t')) + 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)) -#ifndef HLINT ty | Map.null sub = appsT (conT iso'TypeName) [t,b] | otherwise = appsT (conT isoTypeName) [s,t,a,b] -#endif - close =<< ty + quantifyType [] <$> ty @@ -416,11 +413,9 @@ DecQ makeClassyPrismClass t className methodName cons = do r <- newName "r" -#ifndef HLINT let methodType = appsT (conT prism'TypeName) [varT r,return t] -#endif - methodss <- traverse (mkMethod (VarT r)) cons' - classD (cxt[]) className (map PlainTV (r : vs)) (fds r) + methodss <- traverse (mkMethod r) cons' + classD (cxt[]) className (D.plainTV r : vs) (fds r) ( sigD methodName methodType : map return (concat methodss) ) @@ -428,19 +423,21 @@ where mkMethod r con = do Stab cx o _ _ _ b <- computeOpticType t cons con - let stab' = Stab cx o r r b b + 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 stab')) + [ sigD defName (return (stabToType (Set.fromList (r:vNames)) stab')) , valD (varP defName) (normalB body) [] ] cons' = map (over nconName prismName) cons - vs = Set.toList (setOf typeVars t) + vs = D.freeVariablesWellScoped [t] + vNames = map D.tvName vs fds r | null vs = [] - | otherwise = [FunDep [r] vs] + | otherwise = [FunDep [r] vNames] @@ -456,8 +453,8 @@ [NCon] {- Constructors -} -> DecQ makeClassyPrismInstance s className methodName cons = - do let vs = Set.toList (setOf typeVars s) - cls = className `conAppsT` (s : map VarT vs) + do let vs = D.freeVariablesWellScoped [s] + cls = className `conAppsT` (s : map tvbToType vs) instanceD (cxt[]) (return cls) ( valD (varP methodName) @@ -488,7 +485,7 @@ 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' = foldl' (flip Set.insert) s vars + where s' = List.foldl' (flip Set.insert) s vars nconName :: Lens' NCon Name nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x)) @@ -540,9 +537,3 @@ prefix :: Char -> String -> String prefix char str | sameNameAsCon = char:char:str | otherwise = char:str - --- | Quantify all the free variables in a type. -close :: Type -> TypeQ -close t = forallT (map PlainTV (Set.toList vs)) (cxt[]) (return t) - where - vs = setOf typeVars t 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/Setter.hs b/src/Control/Lens/Internal/Setter.hs --- a/src/Control/Lens/Internal/Setter.hs +++ b/src/Control/Lens/Internal/Setter.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | 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 @@ -22,10 +22,12 @@ module Control.Lens.Internal.TH where import Data.Functor.Contravariant +import qualified Data.Set as Set +import Data.Set (Set) import Language.Haskell.TH +import qualified Language.Haskell.TH.Datatype as D +import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Syntax -import qualified Data.Map as Map -import qualified Data.Set as Set #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_lens (version) @@ -58,19 +60,6 @@ conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) - --- | Return 'Name' contained in a 'TyVarBndr'. -bndrName :: TyVarBndr -> Name -bndrName (PlainTV n ) = n -bndrName (KindedTV n _) = n - -fromSet :: (k -> v) -> Set.Set k -> Map.Map k v -#if MIN_VERSION_containers(0,5,0) -fromSet = Map.fromSet -#else -fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ] -#endif - -- | 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] ] @@ -103,6 +92,80 @@ #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 + $ D.datatypeInstTypes di + where + {- + 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 :: [Type] -> [Type] + dropSigsIfNonDataFam + | isDataFamily (D.datatypeVariant di) = id + | otherwise = map dropSig + + 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:concatMap predTypes c) -- stable order + + predTypes :: Pred -> [Type] +#if MIN_VERSION_template_haskell(2,10,0) + predTypes p = [p] +#else + predTypes (ClassP _ ts) = ts + predTypes (EqualP t1 t2) = [t1, t2] +#endif + +-- | 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 + ------------------------------------------------------------------------ -- Manually quoted names ------------------------------------------------------------------------ @@ -219,26 +282,4 @@ ------------------------------------------------------------------------ inlinePragma :: Name -> [DecQ] - -#ifdef INLINING - -#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 - -#else - -inlinePragma _ = [] - -#endif diff --git a/src/Control/Lens/Internal/Typeable.hs b/src/Control/Lens/Internal/Typeable.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/Typeable.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# language CPP #-} -{-# language TypeOperators #-} -{-# language ScopedTypeVariables #-} -module Control.Lens.Internal.Typeable ( - eqT - , typeRep - ) where -#if MIN_VERSION_base (4,7,0) -import Data.Typeable (eqT, typeRep) - -#else - -import Data.Type.Equality -import Data.Typeable (Typeable, TypeRep, gcast, typeOf) - --- | Extract a witness of equality of two types -eqT :: (Typeable a, Typeable b) => Maybe (a :~: b) -eqT = gcast Refl - --- | Takes a value of type @a@ and returns a concrete representation of that type. -typeRep :: forall proxy a . Typeable a => proxy a -> TypeRep -typeRep _ = typeOf (undefined :: a) - -#endif 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 @@ -33,7 +33,7 @@ import Prelude () import Control.Lens.Internal.Prelude -import Control.Monad.Reader as Reader +import Control.Monad import Control.Monad.Trans.Free import Data.Functor.Bind 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,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -51,16 +50,15 @@ , enum , curried, uncurried , flipped - , Swapped(..) + , swapped #if __GLASGOW_HASKELL__ >= 710 , pattern Swapped #endif - , Strict(..) + , strict, lazy #if __GLASGOW_HASKELL__ >= 710 , pattern Strict , pattern Lazy #endif - , lazy , Reversing(..) , reversed #if __GLASGOW_HASKELL__ >= 710 @@ -85,44 +83,25 @@ , bimapping , firsting , seconding -#if __GLASGOW_HASKELL__ >= 708 -- * Coercions , coerced -#endif ) where import Control.Lens.Equality (simple) import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Internal.Context -import Control.Lens.Internal.Coerce import Control.Lens.Internal.Indexed import Control.Lens.Internal.Iso as Iso import Control.Lens.Internal.Magma import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Type -import Control.Monad.State.Lazy as Lazy -import Control.Monad.State.Strict as Strict -import Control.Monad.Writer.Lazy as Lazy hiding (Product, Sum) -import Control.Monad.Writer.Strict as Strict hiding (Product, Sum) -import Control.Monad.RWS.Lazy as Lazy hiding (Product, Sum) -import Control.Monad.RWS.Strict as Strict hiding (Product, Sum) -import Control.Monad.ST.Lazy as Lazy -import Control.Monad.ST as Strict import Data.Bifunctor -import Data.Bifunctor.Biff -import Data.Bifunctor.Flip -import Data.Bifunctor.Product -import Data.Bifunctor.Sum -import Data.Bifunctor.Tannen -import Data.ByteString as StrictB hiding (reverse) -import Data.ByteString.Lazy as LazyB hiding (reverse) +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 @@ -131,12 +110,10 @@ import Data.Functor #endif -#if __GLASGOW_HASKELL__ >= 708 -import Data.Coerce (Coercible) +import Data.Coerce #if __GLASGOW_HASKELL__ < 710 import Data.Type.Coercion #endif -#endif #if __GLASGOW_HASKELL__ >= 710 import qualified GHC.Exts as Exts @@ -146,14 +123,10 @@ import GHC.Exts (TYPE) #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use on" #-} -#endif - -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens --- >>> import Data.Map as Map +-- >>> import qualified Data.Map as Map -- >>> import Data.Foldable -- >>> import Data.Monoid @@ -190,7 +163,7 @@ -- 'from' ('from' l) ≡ l -- @ from :: AnIso s t a b -> Iso b a t s -from l = withIso l $ flip iso +from l = withIso l $ \sa bt -> iso bt sa {-# INLINE from #-} -- | Extract the two functions, one from @s -> a@ and @@ -212,7 +185,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 #-} ----------------------------------------------------------------------------- @@ -352,7 +325,7 @@ -- 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: @@ -363,7 +336,7 @@ -- >>> 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' @@ -373,7 +346,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 @@ -389,7 +362,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 @@ -436,81 +409,29 @@ 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) - -instance (Swapped f, Swapped g) => Swapped (Product f g) where - swapped = iso f f - where - f (Pair x y) = Pair (x ^. swapped) (y ^. swapped) - -instance (Swapped p, Swapped q) => Swapped (Sum p q) where - swapped = iso f f - where - f (L2 x) = L2 (x ^. swapped) - f (R2 x) = R2 (x ^. swapped) - -instance (Swapped p) => Swapped (Flip p) where - swapped = iso f f - where - f (Flip p) = Flip (p ^. swapped) - -instance (f ~ g, Functor f, Swapped p) => Swapped (Biff p f g) where - swapped = iso f f - where - f (Biff p) = Biff (p ^. swapped) - -instance (Functor f, Swapped p) => Swapped (Tannen f p) where - swapped = iso f f - where - f (Tannen x) = Tannen $ fmap (^. swapped) x - -instance Swapped ((,,) x) where - swapped = iso f f - where - f (x,a,b) = (x,b,a) - -instance Swapped ((,,,) x y) where - swapped = iso f f - where - f (x,y,a,b) = (x,y,b,a) - -instance Swapped ((,,,,) x y z) where - swapped = iso f f - where - f (x,y,z,a,b) = (x,y,z,b,a) - -instance Swapped ((,,,,,) x y z w) where - swapped = iso f f - where - f (x,y,z,w,a,b) = (x,y,z,w,b,a) - -instance Swapped ((,,,,,,) x y z w v) where - swapped = iso f f - where - f (x,y,z,w,v,a,b) = (x,y,z,w,v,b,a) +-- | +-- @ +-- '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 #-} --- | 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 +-- | 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 #-} #if __GLASGOW_HASKELL__ >= 710 pattern Strict a <- (view strict -> a) where @@ -526,34 +447,6 @@ Reversed a = review reversed a #endif -instance Strict LazyB.ByteString StrictB.ByteString where -#if MIN_VERSION_bytestring(0,10,0) - strict = iso LazyB.toStrict LazyB.fromStrict -#else - strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return) -#endif - {-# INLINE strict #-} - -instance Strict LazyT.Text StrictT.Text where - strict = iso LazyT.toStrict LazyT.fromStrict - {-# INLINE strict #-} - -instance Strict (Lazy.StateT s m a) (Strict.StateT s m a) where - strict = iso (Strict.StateT . Lazy.runStateT) (Lazy.StateT . Strict.runStateT) - {-# INLINE strict #-} - -instance Strict (Lazy.WriterT w m a) (Strict.WriterT w m a) where - strict = iso (Strict.WriterT . Lazy.runWriterT) (Lazy.WriterT . Strict.runWriterT) - {-# INLINE strict #-} - -instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where - strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST) - {-# INLINE strict #-} - -instance Strict (Lazy.ST s a) (Strict.ST s a) where - strict = iso Lazy.lazyToStrictST Lazy.strictToLazyST - {-# INLINE strict #-} - -- | An 'Iso' between the strict variant of a structure and its lazy -- counterpart. -- @@ -561,10 +454,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. -- @@ -700,7 +592,6 @@ seconding p = withIso p $ \ sa bt -> iso (second sa) (second bt) {-# INLINE seconding #-} -#if __GLASGOW_HASKELL__ >= 708 -- | Data types that are representationally equal are isomorphic. -- -- This is only available on GHC 7.8+ @@ -708,10 +599,13 @@ -- @since 4.13 coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b # if __GLASGOW_HASKELL__ >= 710 -coerced l = rmap (fmap coerce') l .# coerce +coerced l = rmap (fmap coerce) l .# coerce # else coerced l = case sym Coercion :: Coercion a s of Coercion -> rmap (fmap coerce') l .# coerce + +coerce' :: forall a b. Coercible a b => b -> a +coerce' = coerce (id :: a -> a) +{-# INLINE coerce' #-} # endif {-# INLINE coerced #-} -#endif 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 @@ -109,8 +109,8 @@ -- * ALens Combinators , storing , (^#) - , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~) - , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=) + , (#~), (#%~), (#%%~), (<#~), (<#%~) + , (#=), (#%=), (#%%=), (<#=), (<#%=) -- * Common Lenses , devoid @@ -144,13 +144,10 @@ import GHC.Exts (TYPE) #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use ***" #-} -#endif - -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens +-- >>> import Control.Arrow -- >>> import Control.Monad.State -- >>> import Data.Char (chr) -- >>> import Data.List.NonEmpty (NonEmpty ((:|))) @@ -667,7 +664,7 @@ -- -- If you do not need the old value ('Control.Lens.Setter.?~') is more flexible. -- --- >>> import Data.Map as Map +-- >>> import qualified Data.Map as Map -- >>> _2.at "hello" <>> ("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'. -- @@ -1409,7 +1406,7 @@ {-# INLINE (<#%=) #-} -- | A version of ('%%=') that works on 'ALens'. -( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r +(#%%=) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,1) l #%%= f = State.state $ \s -> runPretext (l sell s) f #else @@ -1419,7 +1416,7 @@ State.put t return r #endif -{-# INLINE ( #%%= ) #-} +{-# INLINE (#%%=) #-} -- | A version of ('Control.Lens.Setter.<.~') that works on 'ALens'. -- 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,10 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} - -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} -#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Level 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 @@ -95,20 +95,20 @@ , (<%@=) , (<<%@=) , (^#) - , ( #~ ) - , ( #%~ ) - , ( #%%~ ) - , ( #= ) - , ( #%= ) + , (#~) + , (#%~) + , (#%%~) + , (#=) + , (#%=) , (<#%~) , (<#%=) - , ( #%%= ) + , (#%%=) , (<#~) , (<#=) -- * "Control.Lens.Plated" , (...) -- * "Control.Lens.Review" - , ( # ) + , (#) -- * "Control.Lens.Setter" , (%~) , (.~) 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 @@ -5,10 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -- gplate1 -#endif +{-# LANGUAGE PolyKinds #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell @@ -121,9 +118,12 @@ 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, Typeable) +-- >>> import GHC.Generics (Generic) +-- >>> import Control.Lens -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. -- @@ -263,9 +263,6 @@ 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 @@ -436,6 +433,8 @@ -- '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 #-} @@ -729,6 +728,41 @@ ------------------------------------------------------------------------------- -- | 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, Typeable, Data); data Odd = O Even deriving (Show, Generic, Typeable, 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 #-} 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 @@ -59,19 +59,9 @@ import Data.Profunctor.Sieve import Data.Traversable import Data.Void -#if MIN_VERSION_base(4,7,0) import Data.Coerce -#elif defined(SAFE) -import Data.Profunctor.Unsafe -#else -import Unsafe.Coerce -#endif import Prelude -#ifdef HLINT -{-# ANN module "HLint: ignore Use camelCase" #-} -#endif - -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens @@ -97,23 +87,15 @@ -- | Convert 'APrism' to the pair of functions that characterize it. withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r -#if MIN_VERSION_base(4,7,0) withPrism k f = case coerce (k (Market Identity Right)) of Market bt seta -> f bt seta -#elif defined(SAFE) -withPrism k f = case k (Market Identity Right) of - Market bt seta -> f (runIdentity #. bt) (either (Left . runIdentity) Right . seta) -#else -withPrism k f = case unsafeCoerce (k (Market Identity Right)) of - Market bt seta -> f bt seta -#endif {-# INLINE withPrism #-} -- | Clone a 'Prism' so that you can reuse the same monomorphically typed 'Prism' for different purposes. -- -- See 'Control.Lens.Lens.cloneLens' and 'Control.Lens.Traversal.cloneTraversal' for examples of why you might want to do this. clonePrism :: APrism s t a b -> Prism s t a b -clonePrism k = withPrism k prism +clonePrism k = withPrism k $ \bt sta -> prism bt sta {-# INLINE clonePrism #-} ------------------------------------------------------------------------------ @@ -150,9 +132,9 @@ 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 = - withPrism k $ \bt seta k' -> - withPrism k' $ \dv uevc -> +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) 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 @@ -44,6 +44,7 @@ -- $setup -- >>> import Control.Lens +-- >>> import Control.Applicative ------------------------------------------------------------------------------ -- Lens @@ -256,7 +257,7 @@ {-# INLINE dimap #-} instance Sieve (ReifiedIndexedGetter i) ((,) i) where - sieve = iview . runIndexedGetter + sieve (IndexedGetter l) = iview l {-# INLINE sieve #-} instance Representable (ReifiedIndexedGetter i) where @@ -307,7 +308,7 @@ {-# INLINE lmap #-} instance Sieve ReifiedFold [] where - sieve = toListOf . runFold + sieve (Fold l) = toListOf l instance Representable ReifiedFold where type Rep ReifiedFold = [] 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 @@ -27,10 +27,11 @@ , re , review, reviews , reuse, reuses - , ( # ) + , (#) , Bifunctor(bimap) , retagged , Reviewable + , reviewing ) where import Control.Monad.Reader as Reader @@ -48,7 +49,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 @@ -164,9 +167,9 @@ -- (#) :: 'Review' s a -> a -> s -- (#) :: 'Equality'' s a -> a -> s -- @ -( # ) :: AReview t 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. @@ -240,3 +243,13 @@ 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 @@ -89,18 +89,13 @@ import Control.Monad.State.Class as State import Control.Monad.Writer.Class as Writer -#ifdef HLINT -{-# ANN module "HLint: ignore Avoid lambda" #-} -{-# ANN module "HLint: ignore Use fmap" #-} -#endif - -- $setup -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Char -- >>> import Data.Functor.Contravariant (Predicate (..), Op (..)) --- >>> import Data.Map as Map --- >>> import Data.Semigroup (Sum (..), Product (..)) +-- >>> import qualified Data.Map as Map +-- >>> import Data.Semigroup (Sum (..), Product (..), Semigroup (..)) -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f @@ -532,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" Just DataDecl { dataContext = ctx , tyConName = Nothing - , dataParameters = map PlainTV vars + , dataParameters = map D.plainTV vars , fullType = \tys -> apps (ConT familyName) $ substType (Map.fromList $ zip vars tys) args , constructors = cons @@ -547,7 +542,7 @@ { dataContext :: Cxt -- ^ Datatype context. , tyConName :: Maybe Name -- ^ Type constructor name, or Nothing for a data family instance. - , dataParameters :: [TyVarBndr] -- ^ List of type parameters + , dataParameters :: [TyVarBndrUnit] -- ^ List of type parameters , fullType :: [Type] -> Type -- ^ Create a concrete record type given a substitution to -- 'detaParameters'. @@ -633,13 +628,6 @@ -- _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 - overHead :: (a -> a) -> [a] -> [a] overHead _ [] = [] overHead f (x:xs) = f x : xs @@ -857,7 +845,7 @@ -- | 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 +traverseDataAndNewtype f = traverse go where go dec = case dec of DataD{} -> f dec 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 @@ -167,9 +167,11 @@ -- >>> :set -XNoOverloadedStrings -XFlexibleContexts -- >>> import Data.Char (toUpper) -- >>> import Control.Lens +-- >>> import Control.Lens.Internal.Context -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate,try,ErrorCall(..)) -- >>> import Data.Maybe (fromMaybe) +-- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Debug.SimpleReflect.Vars -- >>> import Data.Void -- >>> import Data.List (sort) @@ -734,7 +736,7 @@ {-# INLINABLE holeInOne #-} -- | The non-empty version of 'holesOf'. --- This extract a non-empty list of immediate children accroding to a given +-- 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 @@ -1161,11 +1163,7 @@ 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 #-} @@ -1182,11 +1180,7 @@ 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 #-} @@ -1228,7 +1222,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. @@ -1250,7 +1244,7 @@ -- '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. 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 @@ -10,9 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif #include "lens-common.h" @@ -58,6 +56,7 @@ import Control.Lens.Lens import Control.Lens.Internal.Prelude import Data.Functor.Product (Product (..)) +import Data.Strict (Pair (..)) import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..), U1 (..)) @@ -109,6 +108,10 @@ 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 -- @ @@ -215,6 +218,10 @@ 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 -- @ @@ -1182,14 +1189,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) 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,10 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-} #endif @@ -464,10 +461,8 @@ -- Note: Composition with an 'Equality' is index-preserving. #if __GLASGOW_HASKELL__ >= 800 type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall k3 (p :: k1 -> k3 -> Type) (f :: k2 -> k3) . -#elif __GLASGOW_HASKELL__ >= 706 -type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall (p :: k1 -> * -> *) (f :: k2 -> *) . #else -type Equality s t a b = forall p (f :: * -> *) . +type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall (p :: k1 -> * -> *) (f :: k2 -> *) . #endif p a (f b) -> p s (f t) diff --git a/src/Control/Lens/Unsound.hs b/src/Control/Lens/Unsound.hs --- a/src/Control/Lens/Unsound.hs +++ b/src/Control/Lens/Unsound.hs @@ -3,14 +3,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} -#endif - {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Unsound @@ -37,6 +34,10 @@ 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 'Lens' if the input lenses project disjoint parts of -- the structure @s@. Otherwise "you get what you put in" law @@ -80,9 +81,9 @@ prismSum :: APrism s t a b -> APrism s t c d -> Prism s t (Either a c) (Either b d) -prismSum k = - withPrism k $ \bt seta k' -> - withPrism k' $ \dt setb -> +prismSum k k' = + withPrism k $ \bt seta -> + withPrism k' $ \dt setb -> prism (either bt dt) $ \s -> f (Left <$> seta s) (Right <$> setb s) where 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 @@ -7,10 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} @@ -129,12 +126,17 @@ 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.List.NonEmpty -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.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map as Map +import Data.Map (Map) import Data.Monoid import qualified Data.Profunctor as Profunctor import Data.Profunctor hiding (WrappedArrow(..)) @@ -143,36 +145,34 @@ import Data.Semigroupoid import qualified Data.Semigroupoid.Dual as Semigroupoid import Data.Semigroupoid.Static -import Data.Sequence as Seq hiding (length) -import Data.Set as Set +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) +import qualified Data.Set as Set +import Data.Set (Set) import Data.Tagged -import Data.Vector as Vector -import Data.Vector.Primitive as Prim -import Data.Vector.Unboxed as Unboxed -import Data.Vector.Storable as Storable +import qualified Data.Vector as Vector +import qualified Data.Vector.Primitive as Prim +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Unboxed as Unboxed +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Storable as Storable import Foreign.C.Error import Foreign.C.Types +import Foreign.Storable (Storable) import qualified GHC.Generics as Generic import GHC.Generics hiding (from, to) import System.Posix.Types - -#if MIN_VERSION_base(4,6,0) import Data.Ord (Down(Down)) -#else -import GHC.Exts (Down(Down)) -#endif #if MIN_VERSION_base(4,8,0) import qualified Data.Monoid as Monoid #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use uncurry" #-} -#endif - -- $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 -- data types with one constructor. @@ -1357,7 +1357,7 @@ -- @ ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s) -ala = xplat . _Unwrapping +ala f = xplat $ _Unwrapping f {-# INLINE ala #-} -- | This combinator is based on @ala'@ from Conor McBride's work on Epigram. @@ -1371,5 +1371,5 @@ -- >>> alaf Sum foldMap Prelude.length ["hello","world"] -- 10 alaf :: (Functor f, Functor g, Rewrapping s t) => (Unwrapped s -> s) -> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s) -alaf = xplatf . _Unwrapping +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 @@ -6,10 +6,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} -#endif #include "lens-common.h" @@ -53,14 +50,11 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Free -#ifdef HLINT -{-# ANN module "HLint: ignore Use fmap" #-} -#endif - -- $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 = Debug.SimpleReflect.Vars.f 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 @@ -40,10 +40,6 @@ import Data.Semigroup (Semigroup(..)) #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use fmap" #-} -#endif - ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ 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 @@ -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 @@ -28,9 +28,10 @@ import Data.Bits import Data.Word - -- $setup -- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens +-- >>> import Control.Monad.State -- >>> import Data.Word infixr 4 .|.~, .&.~, <.|.~, <.&.~, <<.|.~, <<.&.~ 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 @@ -28,14 +28,17 @@ 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'. -- @@ -48,7 +51,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 @@ -99,7 +102,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' 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 @@ -26,9 +26,9 @@ 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. @@ -113,7 +113,7 @@ #if __GLASGOW_HASKELL__ >= 710 pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b - + pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b #endif 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 @@ -26,14 +26,16 @@ 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' -- @@ -46,7 +48,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 @@ -97,7 +99,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' 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 @@ -40,6 +40,8 @@ import Data.Complex -- $setup +-- >>> import Control.Lens +-- >>> import Data.Complex -- >>> import Debug.SimpleReflect -- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ } 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,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} -#ifndef HLINT {-# LANGUAGE UnboxedTuples #-} -#endif {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} @@ -74,16 +72,9 @@ import Prelude import qualified Data.Proxy as X (Proxy (..)) -import qualified Control.Lens.Internal.Typeable as X +import qualified Data.Typeable as X (typeRep, eqT) import qualified Data.Type.Equality as X -#ifdef HLINT -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Use foldl" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} -{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} -#endif - -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens @@ -332,13 +323,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 @@ -402,7 +391,7 @@ 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 a0 = go2 a0 where +biplateData o f = go2 where go :: Data d => d -> f d go s = gfoldl (\x y -> x <*> go2 y) pure s go2 :: Data d => d -> f d @@ -413,7 +402,7 @@ {-# INLINE biplateData #-} uniplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s -uniplateData o f a0 = go a0 where +uniplateData o f = go where go :: Data d => d -> f d go s = gfoldl (\x y -> x <*> go2 y) pure s go2 :: Data d => d -> f d 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 @@ -17,7 +17,8 @@ import Control.Lens.Getter (Getting, views) import Control.Lens.Setter (setting) import Control.Lens.Type -import Data.HashSet as HashSet +import qualified Data.HashSet as HashSet +import Data.HashSet (HashSet) import Data.Hashable -- $setup 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 @@ -16,11 +16,13 @@ ) 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'. -- @@ -37,7 +39,7 @@ -- 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 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 @@ -99,10 +99,11 @@ import Control.Monad (guard) import Control.Lens.Internal.Prelude import Control.Lens -import Data.List +import qualified Data.List as List -- $setup -- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f @@ -120,7 +121,7 @@ -- >>> prefixed "pre" # "amble" -- "preamble" prefixed :: Eq a => [a] -> Prism' [a] [a] -prefixed ps = prism' (ps ++) (stripPrefix ps) +prefixed ps = prism' (ps ++) (List.stripPrefix ps) {-# INLINE prefixed #-} -- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or 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 @@ -70,6 +70,7 @@ -- $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' 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 @@ -19,10 +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 @@ -43,7 +47,7 @@ -- >>> EmptyL ^. from viewL -- fromList [] -- --- >>> review viewL $ a Seq.:< 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 @@ -64,7 +68,7 @@ -- >>> EmptyR ^. from viewR -- fromList [] -- --- >>> review viewR $ fromList [a,b] Seq.:> 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 @@ -74,13 +78,13 @@ -- | 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 @@ -89,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 @@ -104,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 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 @@ -23,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. @@ -36,13 +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] -#if MIN_VERSION_containers(0,5,2) setmapped :: Ord j => IndexPreservingSetter (Set i) (Set j) i j -#else -setmapped :: (Ord i, Ord j) => IndexPreservingSetter (Set i) (Set j) i j -#endif 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 @@ -36,15 +36,18 @@ #endif import Control.Lens.Setter import Control.Lens.Traversal -import Data.ByteString.Lazy as ByteString +import Data.ByteString.Lazy (ByteString) import Data.Monoid -import Data.Text.Lazy as Text -import Data.Text.Lazy.Builder +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'. -- @@ -98,7 +101,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'. 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 @@ -32,14 +32,15 @@ #endif import Control.Lens.Iso import Control.Lens.Traversal -import Data.Text as Strict +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 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 @@ -37,10 +37,12 @@ import Control.Lens.Traversal import Data.ByteString (ByteString) import Data.Monoid -import Data.Text as Strict +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 @@ -59,7 +61,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'. @@ -79,7 +81,7 @@ -- '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 '#' @@ -97,7 +99,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'. 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 @@ -23,6 +23,10 @@ import Control.Lens import Data.Tree +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Tree + -- | A 'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 [] 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 @@ -36,7 +36,8 @@ , vectorTraverse ) where -import Control.Applicative +import Prelude () + import Control.Lens.Type import Control.Lens.Lens import Control.Lens.Getter @@ -46,10 +47,10 @@ import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Internal.List (ordinalNub) -import Data.Monoid -import Data.Vector.Generic as V hiding (zip, filter, indexed) +import Control.Lens.Internal.Prelude +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) #if MIN_VERSION_vector(0,11,0) import Data.Vector.Fusion.Bundle (Bundle) @@ -58,7 +59,8 @@ #endif -- $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'. @@ -78,7 +80,7 @@ => 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'. @@ -86,7 +88,7 @@ -- >>> (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.) @@ -97,7 +99,7 @@ -- >>> Vector.fromList [0,8,15] ^. from vector -- [0,8,15] vector :: (Vector v a, Vector v b) => Iso [a] [b] (v a) (v b) -vector = iso fromList V.toList +vector = iso V.fromList V.toList {-# INLINE vector #-} #if MIN_VERSION_vector(0,11,0) @@ -107,7 +109,7 @@ -- | Convert a 'Vector' to a finite 'Stream' (or back.) asStream :: (Vector v a, Vector v b) => Iso (v a) (v b) (Stream a) (Stream b) #endif -asStream = iso stream unstream +asStream = iso V.stream V.unstream {-# INLINE asStream #-} #if MIN_VERSION_vector(0,11,0) @@ -119,19 +121,19 @@ -- back.) asStreamR :: (Vector v a, Vector v b) => Iso (v a) (v b) (Stream a) (Stream b) #endif -asStreamR = iso streamR unstreamR +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 @@ -140,7 +142,7 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: Vector v a => [Int] -> IndexedTraversal' Int (v a) a -ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ ordinalNub (length v) is +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. @@ -164,4 +166,4 @@ -- | 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 convert convert +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 @@ -28,13 +28,18 @@ , ordinals ) where -import Control.Applicative +import Prelude () + import Control.Lens import Control.Lens.Internal.List (ordinalNub) -import Data.Vector as Vector hiding (zip, filter, indexed) -import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) -import Data.Monoid +import Control.Lens.Internal.Prelude +import qualified Data.Vector as V +import Data.Vector (Vector) +-- $setup +-- >>> import qualified Data.Vector as Vector +-- >>> import Control.Lens + -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting -- at index @i@ from a 'Lens'. -- @@ -52,7 +57,7 @@ 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'. @@ -60,7 +65,7 @@ -- >>> 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) @@ -74,13 +79,13 @@ -- >>> 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 @@ -89,5 +94,5 @@ -- >>> 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)) $ ordinalNub (length v) is +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 @@ -4,9 +4,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens @@ -64,17 +62,18 @@ -- $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 => Iso' a (Rep a b) +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 => Iso (f a) (f b) (Rep1 f a) (Rep1 f b) +generic1 :: (Generic1 f, Generic1 g) => Iso (f a) (g b) (Rep1 f a) (Rep1 g b) generic1 = iso from1 to1 {-# INLINE generic1 #-} 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif @@ -61,14 +62,12 @@ -- ** FieldPat Lenses , fieldPatName , fieldPatPattern -#if MIN_VERSION_template_haskell(2,9,0) -- ** TySynEqn Lenses # if MIN_VERSION_template_haskell(2,15,0) , tySynEqnLHS # endif , tySynEqnPatterns , tySynEqnResult -#endif #if MIN_VERSION_template_haskell(2,11,0) -- ** InjectivityAnn Lenses , injectivityAnnOutput @@ -110,17 +109,13 @@ , _InstanceD , _SigD , _ForeignD -#if MIN_VERSION_template_haskell(2,8,0) , _InfixD -#endif , _PragmaD , _DataInstD , _NewtypeInstD , _TySynInstD -#if MIN_VERSION_template_haskell(2,9,0) , _ClosedTypeFamilyD , _RoleAnnotD -#endif #if MIN_VERSION_template_haskell(2,10,0) , _StandaloneDerivD , _DefaultSigD @@ -201,12 +196,9 @@ -- ** Pragma Prisms , _InlineP , _SpecialiseP -#if MIN_VERSION_template_haskell(2,8,0) , _SpecialiseInstP , _RuleP -#if MIN_VERSION_template_haskell(2,9,0) , _AnnP -#endif #if MIN_VERSION_template_haskell(2,10,0) , _LineP #endif @@ -227,13 +219,10 @@ -- ** 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 #if !(MIN_VERSION_template_haskell(2,13,0)) @@ -257,18 +246,14 @@ , _UInfixE , _ParensE , _LamE -#if MIN_VERSION_template_haskell(2,8,0) , _LamCaseE -#endif , _TupE , _UnboxedTupE #if MIN_VERSION_template_haskell(2,12,0) , _UnboxedSumE #endif , _CondE -#if MIN_VERSION_template_haskell(2,8,0) , _MultiIfE -#endif , _LetE , _CaseE , _DoE @@ -352,9 +337,7 @@ , _SigT , _VarT , _ConT -#if MIN_VERSION_template_haskell(2,8,0) , _PromotedT -#endif , _TupleT , _UnboxedTupleT #if MIN_VERSION_template_haskell(2,12,0) @@ -365,14 +348,12 @@ , _EqualityT #endif , _ListT -#if MIN_VERSION_template_haskell(2,8,0) , _PromotedTupleT , _PromotedNilT , _PromotedConsT , _StarT , _ConstraintT , _LitT -#endif #if MIN_VERSION_template_haskell(2,11,0) , _InfixT , _UInfixT @@ -386,6 +367,14 @@ #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,17,0) + -- ** Specificity Prisms + , _SpecifiedSpec + , _InferredSpec +#endif -- ** TyVarBndr Prisms , _PlainTV , _KindedTV @@ -395,23 +384,19 @@ , _KindSig , _TyVarSig #endif -#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 , _PhantomR , _InferR -#endif #if MIN_VERSION_template_haskell(2,12,0) -- ** DerivStrategy Prisms , _StockStrategy @@ -430,16 +415,17 @@ import Control.Lens.Prism import Control.Lens.Tuple import Control.Lens.Traversal -import Data.Map as Map hiding (toList,map) +import qualified Data.Map as Map +import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid -import Data.Set as Set hiding (toList,map) +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 -#if MIN_VERSION_template_haskell(2,8,0) import Data.Word -#endif #if MIN_VERSION_template_haskell(2,15,0) import Control.Lens.Internal.TH (unfoldType) import Data.Foldable as F (foldl') @@ -451,9 +437,8 @@ -- | 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 (TyVarBndr_ flag) where + name = traverseTVName instance HasName Name where name = id @@ -478,11 +463,9 @@ name f (ExportF cc str n ty) = (\n' -> ExportF cc str n' ty) <$> f n -#if MIN_VERSION_template_haskell(2,8,0) instance HasName RuleBndr where name f (RuleVar n) = RuleVar <$> f n name f (TypedRuleVar n ty) = (`TypedRuleVar` ty) <$> f n -#endif #if MIN_VERSION_template_haskell(2,11,0) instance HasName TypeFamilyHead where @@ -518,20 +501,17 @@ 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 -#if MIN_VERSION_template_haskell(2,9,0) 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 tvb@PlainTV{} = pure tvb - go (KindedTV n k) = KindedTV n <$> f k + go = traverseTVKind f #else types f (TySynEqn lhss rhs) = TySynEqn <$> traverse (types f) lhss <*> types f rhs #endif -#endif instance HasTypes t => HasTypes [t] where types = traverse . types @@ -543,7 +523,7 @@ -- the 'Traversal' laws, when in doubt generate your names with 'newName'. typeVarsEx :: Set Name -> Traversal' t Name -instance HasTypeVars TyVarBndr where +instance HasTypeVars (TyVarBndr_ flag) where typeVarsEx s f b | s^.contains (b^.name) = pure b | otherwise = name f b @@ -563,13 +543,8 @@ typeVarsEx _ _ t@ListT{} = pure t typeVarsEx _ _ t@ArrowT{} = pure t typeVarsEx _ _ t@UnboxedTupleT{} = pure t -#if MIN_VERSION_template_haskell(2,8,0) typeVarsEx s f (SigT t k) = SigT <$> typeVarsEx s f t <*> typeVarsEx s f k -#else - typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t -#endif -#if MIN_VERSION_template_haskell(2,8,0) typeVarsEx _ _ t@PromotedT{} = pure t typeVarsEx _ _ t@PromotedTupleT{} = pure t typeVarsEx _ _ t@PromotedNilT{} = pure t @@ -577,7 +552,6 @@ typeVarsEx _ _ t@StarT{} = pure t typeVarsEx _ _ t@ConstraintT{} = pure t typeVarsEx _ _ t@LitT{} = pure t -#endif #if MIN_VERSION_template_haskell(2,10,0) typeVarsEx _ _ t@EqualityT{} = pure t #endif @@ -603,6 +577,9 @@ 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,10,0) instance HasTypeVars Pred where @@ -656,12 +633,7 @@ 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) -#if MIN_VERSION_template_haskell(2,8,0) (substType m k) -#else - k -#endif -#if MIN_VERSION_template_haskell(2,8,0) substType _ t@PromotedT{} = t substType _ t@PromotedTupleT{} = t substType _ t@PromotedNilT{} = t @@ -669,7 +641,6 @@ substType _ t@StarT{} = t substType _ t@ConstraintT{} = t substType _ t@LitT{} = t -#endif #if MIN_VERSION_template_haskell(2,10,0) substType _ t@EqualityT{} = t #endif @@ -690,6 +661,9 @@ 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 instance SubstType t => SubstType [t] where substType = map . substType @@ -856,7 +830,7 @@ g (TypeFamilyHead n _ _ _ ) = n s (TypeFamilyHead _ tvbs rs ia) n = TypeFamilyHead n tvbs rs ia -typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndr] +typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndrUnit] typeFamilyHeadTyVarBndrs = lens g s where g (TypeFamilyHead _ tvbs _ _ ) = tvbs s (TypeFamilyHead n _ rs ia) tvbs = TypeFamilyHead n tvbs rs ia @@ -894,11 +868,7 @@ s (DerivClause mds _) = DerivClause mds #endif -#if MIN_VERSION_template_haskell(2,8,0) _ClassI :: Prism' Info (Dec, [InstanceDec]) -#else -_ClassI :: Prism' Info (Dec, [Dec]) -#endif _ClassI = prism' reviewer remitter where @@ -921,11 +891,7 @@ remitter (ClassOpI x y z) = Just (x, y, z) remitter _ = Nothing #else -# if MIN_VERSION_template_haskell(2,8,0) _ClassOpI :: Prism' Info (Name, Type, ParentName, Fixity) -# else -_ClassOpI :: Prism' Info (Name, Type, Name, Fixity) -# endif _ClassOpI = prism' reviewer remitter where @@ -954,11 +920,7 @@ remitter (FamilyI x y) = Just (x, y) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PrimTyConI :: Prism' Info (Name, Arity, Unlifted) -#else -_PrimTyConI :: Prism' Info (Name, Int, Bool) -#endif _PrimTyConI = prism' reviewer remitter where @@ -981,11 +943,7 @@ remitter (DataConI x y z) = Just (x, y, z) remitter _ = Nothing #else -# if MIN_VERSION_template_haskell(2,8,0) _DataConI :: Prism' Info (Name, Type, ParentName, Fixity) -# else -_DataConI :: Prism' Info (Name, Type, Name, Fixity) -# endif _DataConI = prism' reviewer remitter where @@ -1051,7 +1009,7 @@ remitter (ValD x y z) = Just (x, y, z) remitter _ = Nothing -_TySynD :: Prism' Dec (Name, [TyVarBndr], Type) +_TySynD :: Prism' Dec (Name, [TyVarBndrUnit], Type) _TySynD = prism' reviewer remitter where @@ -1059,7 +1017,7 @@ remitter (TySynD x y z) = Just (x, y, z) remitter _ = Nothing -_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndr], [FunDep], [Dec]) +_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], [FunDep], [Dec]) _ClassD = prism' reviewer remitter where @@ -1135,7 +1093,6 @@ remitter (ForeignD x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _InfixD :: Prism' Dec (Fixity, Name) _InfixD = prism' reviewer remitter @@ -1143,7 +1100,6 @@ reviewer (x, y) = InfixD x y remitter (InfixD x y) = Just (x, y) remitter _ = Nothing -#endif _PragmaD :: Prism' Dec Pragma _PragmaD @@ -1167,7 +1123,7 @@ reviewer = TySynInstD remitter (TySynInstD x) = Just x remitter _ = Nothing -#elif MIN_VERSION_template_haskell(2,9,0) +#else _TySynInstD :: Prism' Dec (Name, TySynEqn) _TySynInstD = prism' reviewer remitter @@ -1175,17 +1131,8 @@ reviewer (x, y) = TySynInstD x y remitter (TySynInstD x y) = Just (x, y) remitter _ = Nothing -#else -_TySynInstD :: Prism' Dec (Name, [Type], Type) -_TySynInstD - = prism' reviewer remitter - where - reviewer (x, y, z) = TySynInstD x y z - remitter (TySynInstD x y z) = Just (x, y, z) - remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _RoleAnnotD :: Prism' Dec (Name, [Role]) _RoleAnnotD = prism' reviewer remitter @@ -1193,7 +1140,6 @@ reviewer (x, y) = RoleAnnotD x y remitter (RoleAnnotD x y) = Just (x, y) remitter _ = Nothing -#endif -- | -- @ @@ -1236,13 +1182,13 @@ -- | -- @ --- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndr'], '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') -- template-haskell-2.11 --- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions +-- _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') -- template-haskell-2.11 +-- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0) -_DataInstD :: Prism' Dec (Cxt, Maybe [TyVarBndr], Type, Maybe Kind, [Con], [DerivClause]) +_DataInstD :: Prism' Dec (Cxt, Maybe [TyVarBndrUnit], Type, Maybe Kind, [Con], [DerivClause]) _DataInstD = prism' reviewer remitter where @@ -1269,13 +1215,13 @@ -- | -- @ --- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndr'], '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') -- template-haskell-2.11 --- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions +-- _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') -- template-haskell-2.11 +-- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0) -_NewtypeInstD :: Prism' Dec (Cxt, Maybe [TyVarBndr], Type, Maybe Kind, Con, [DerivClause]) +_NewtypeInstD :: Prism' Dec (Cxt, Maybe [TyVarBndrUnit], Type, Maybe Kind, Con, [DerivClause]) _NewtypeInstD = prism' reviewer remitter where @@ -1308,8 +1254,8 @@ reviewer (x, y) = ClosedTypeFamilyD x y remitter (ClosedTypeFamilyD x y) = Just (x, y) remitter _ = Nothing -#elif MIN_VERSION_template_haskell(2,9,0) -_ClosedTypeFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind, [TySynEqn]) +#else +_ClosedTypeFamilyD :: Prism' Dec (Name, [TyVarBndrUnit], Maybe Kind, [TySynEqn]) _ClosedTypeFamilyD = prism' reviewer remitter where @@ -1320,12 +1266,12 @@ -- | -- @ --- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndr'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12+ --- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- template-haskell-2.11 --- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions +-- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12+ +-- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- template-haskell-2.11 +-- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,11,0) -_DataD :: DataPrism' [TyVarBndr] [Con] +_DataD :: DataPrism' [TyVarBndrUnit] [Con] _DataD = prism' reviewer remitter where @@ -1333,7 +1279,7 @@ remitter (DataD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else -_DataD :: Prism' Dec (Cxt, Name, [TyVarBndr], [Con], [Name]) +_DataD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], [Con], [Name]) _DataD = prism' reviewer remitter where @@ -1344,12 +1290,12 @@ -- | -- @ --- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndr'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12+ --- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- template-haskell-2.11 --- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions +-- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12+ +-- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- template-haskell-2.11 +-- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,11,0) -_NewtypeD :: DataPrism' [TyVarBndr] Con +_NewtypeD :: DataPrism' [TyVarBndrUnit] Con _NewtypeD = prism' reviewer remitter where @@ -1357,7 +1303,7 @@ remitter (NewtypeD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else -_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndr], Con, [Name]) +_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], Con, [Name]) _NewtypeD = prism' reviewer remitter where @@ -1367,7 +1313,7 @@ #endif #if MIN_VERSION_template_haskell(2,11,0) -_DataFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind) +_DataFamilyD :: Prism' Dec (Name, [TyVarBndrUnit], Maybe Kind) _DataFamilyD = prism' reviewer remitter where @@ -1383,7 +1329,7 @@ remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing #else -_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndr], Maybe Kind) +_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndrUnit], Maybe Kind) _FamilyD = prism' reviewer remitter where @@ -1529,7 +1475,7 @@ remitter (InfixC x y z) = Just (x, y, z) remitter _ = Nothing -_ForallC :: Prism' Con ([TyVarBndr], Cxt, Con) +_ForallC :: Prism' Con ([TyVarBndrSpec], Cxt, Con) _ForallC = prism' reviewer remitter where @@ -1735,12 +1681,6 @@ remitter Interruptible = Just () remitter _ = Nothing --- | --- @ --- _InlineP :: 'Prism'' 'Pragma' ('Name', 'Inline', 'RuleMatch', 'Phases') -- template-haskell-2.8+ --- _InlineP :: 'Prism'' 'Pragma' ('Name', 'Inline') -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,8,0) _InlineP :: Prism' Pragma (Name, Inline, RuleMatch, Phases) _InlineP = prism' reviewer remitter @@ -1748,22 +1688,7 @@ reviewer (x, y, z, w) = InlineP x y z w remitter (InlineP x y z w) = Just (x, y, z, w) remitter _ = Nothing -#else -_InlineP :: Prism' Pragma (Name, InlineSpec) -_InlineP - = prism' reviewer remitter - where - reviewer (x, y) = InlineP x y - remitter (InlineP x y) = Just (x, y) - remitter _ = Nothing -#endif --- | --- @ --- _SpecialiseP :: 'Prism'' 'Pragma' ('Name', 'Type', 'Maybe' 'Inline', 'Phases') -- template-haskell-2.8+ --- _SpecialiseP :: 'Prism'' 'Pragma' ('Name', 'Type', 'Maybe' 'InlineSpec') -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,8,0) _SpecialiseP :: Prism' Pragma (Name, Type, Maybe Inline, Phases) _SpecialiseP = prism' reviewer remitter @@ -1771,19 +1696,9 @@ reviewer (x, y, z, w) = SpecialiseP x y z w remitter (SpecialiseP x y z w) = Just (x, y, z, w) remitter _ = Nothing -#else -_SpecialiseP :: Prism' Pragma (Name, Type, Maybe InlineSpec) -_SpecialiseP - = prism' reviewer remitter - where - reviewer (x, y, z) = SpecialiseP x y z - remitter (SpecialiseP x y z) = Just (x, y, z) - remitter _ = Nothing -#endif -- TODO add lenses for InlineSpec -#if MIN_VERSION_template_haskell(2,8,0) _SpecialiseInstP :: Prism' Pragma Type _SpecialiseInstP = prism' reviewer remitter @@ -1794,11 +1709,11 @@ -- | -- @ --- _RuleP :: 'Prism'' 'Pragma' ('String', 'Maybe' ['TyVarBndr'], ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- template-haskell-2.15+ --- _RuleP :: 'Prism'' 'Pragma' ('String', ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- Earlier versions +-- _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 [TyVarBndr], [RuleBndr], Exp, Exp, Phases) +_RuleP :: Prism' Pragma (String, Maybe [TyVarBndrUnit], [RuleBndr], Exp, Exp, Phases) _RuleP = prism' reviewer remitter where @@ -1815,7 +1730,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _AnnP :: Prism' Pragma (AnnTarget, Exp) _AnnP = prism' reviewer remitter @@ -1823,7 +1737,6 @@ reviewer (x, y) = AnnP x y remitter (AnnP x y) = Just (x, y) remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,10,0) _LineP :: Prism' Pragma (Int, String) @@ -1924,9 +1837,7 @@ reviewer (x, y) = TypedRuleVar x y remitter (TypedRuleVar x y) = Just (x, y) remitter _ = Nothing -#endif -#if MIN_VERSION_template_haskell(2,9,0) _ModuleAnnotation :: Prism' AnnTarget () _ModuleAnnotation = prism' reviewer remitter @@ -1950,7 +1861,6 @@ reviewer = ValueAnnotation remitter (ValueAnnotation x) = Just x remitter _ = Nothing -#endif _FunDep :: Iso' FunDep ([Name], [Name]) _FunDep @@ -1994,7 +1904,7 @@ tySynEqnResult = lens g s where g (TySynEqn _ _ rhs) = rhs s (TySynEqn mtvbs lhs _) = TySynEqn mtvbs lhs -#elif MIN_VERSION_template_haskell(2,9,0) +#else tySynEqnPatterns :: Lens' TySynEqn [Type] tySynEqnPatterns = lens g s where g (TySynEqn xs _) = xs @@ -2104,7 +2014,6 @@ remitter (LamE x y) = Just (x, y) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _LamCaseE :: Prism' Exp [Match] _LamCaseE = prism' reviewer remitter @@ -2112,7 +2021,6 @@ reviewer = LamCaseE remitter (LamCaseE x) = Just x remitter _ = Nothing -#endif -- | -- @ @@ -2166,7 +2074,6 @@ remitter (CondE x y z) = Just (x, y, z) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _MultiIfE :: Prism' Exp [(Guard, Exp)] _MultiIfE = prism' reviewer remitter @@ -2174,7 +2081,6 @@ reviewer = MultiIfE remitter (MultiIfE x) = Just x remitter _ = Nothing -#endif _LetE :: Prism' Exp ([Dec], Exp) _LetE @@ -2192,6 +2098,20 @@ 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 @@ -2199,6 +2119,7 @@ reviewer = DoE remitter (DoE x) = Just x remitter _ = Nothing +# endif _CompE :: Prism' Exp [Stmt] _CompE @@ -2279,6 +2200,20 @@ #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 @@ -2286,6 +2221,7 @@ reviewer = MDoE remitter (MDoE x) = Just x remitter _ = Nothing +# endif _ImplicitParamVarE :: Prism' Exp String _ImplicitParamVarE @@ -2466,7 +2402,6 @@ remitter (DoublePrimL x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _StringPrimL :: Prism' Lit [Word8] _StringPrimL = prism' reviewer remitter @@ -2474,15 +2409,6 @@ reviewer = StringPrimL remitter (StringPrimL x) = Just x remitter _ = Nothing -#else -_StringPrimL :: Prism' Lit String -_StringPrimL - = prism' reviewer remitter - where - reviewer = StringPrimL - remitter (StringPrimL x) = Just x - remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,11,0) _CharPrimL :: Prism' Lit Char @@ -2642,7 +2568,7 @@ remitter (ViewP x y) = Just (x, y) remitter _ = Nothing -_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type) +_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter where @@ -2682,7 +2608,6 @@ remitter (ConT x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PromotedT :: Prism' Type Name _PromotedT = prism' reviewer remitter @@ -2690,7 +2615,6 @@ reviewer = PromotedT remitter (PromotedT x) = Just x remitter _ = Nothing -#endif _TupleT :: Prism' Type Int _TupleT @@ -2744,7 +2668,6 @@ remitter ListT = Just () remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PromotedTupleT :: Prism' Type Int _PromotedTupleT = prism' reviewer remitter @@ -2792,7 +2715,6 @@ reviewer = LitT remitter (LitT x) = Just x remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,11,0) _InfixT :: Prism' Type (Type, Name, Type) @@ -2847,7 +2769,7 @@ #endif #if MIN_VERSION_template_haskell(2,16,0) -_ForallVisT :: Prism' Type ([TyVarBndr], Type) +_ForallVisT :: Prism' Type ([TyVarBndrUnit], Type) _ForallVisT = prism' reviewer remitter where @@ -2856,6 +2778,48 @@ 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,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 + +-- | +-- @ +-- _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 @@ -2863,7 +2827,22 @@ 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 @@ -2871,6 +2850,7 @@ reviewer (x, y) = KindedTV x y remitter (KindedTV x y) = Just (x, y) remitter _ = Nothing +#endif #if MIN_VERSION_template_haskell(2,11,0) _NoSig :: Prism' FamilyResultSig () @@ -2889,7 +2869,7 @@ remitter (KindSig x) = Just x remitter _ = Nothing -_TyVarSig :: Prism' FamilyResultSig TyVarBndr +_TyVarSig :: Prism' FamilyResultSig TyVarBndrUnit _TyVarSig = prism' reviewer remitter where @@ -2898,7 +2878,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,8,0) _NumTyLit :: Prism' TyLit Integer _NumTyLit = prism' reviewer remitter @@ -2914,7 +2893,6 @@ reviewer = StrTyLit remitter (StrTyLit x) = Just x remitter _ = Nothing -#endif #if !MIN_VERSION_template_haskell(2,10,0) _ClassP :: Prism' Pred (Name, [Type]) @@ -2934,7 +2912,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _NominalR :: Prism' Role () _NominalR = prism' reviewer remitter @@ -2966,7 +2943,6 @@ reviewer () = InferR remitter InferR = Just () remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,12,0) _StockStrategy :: Prism' DerivStrategy () diff --git a/src/Numeric/Lens.hs b/src/Numeric/Lens.hs --- a/src/Numeric/Lens.hs +++ b/src/Numeric/Lens.hs @@ -43,6 +43,7 @@ -- $setup -- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens -- >>> import Data.Monoid (Sum(..)) -- | This 'Prism' can be used to model the fact that every 'Integral' 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 @@ -31,6 +31,9 @@ -- $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), diff --git a/tests/T917.hs b/tests/T917.hs new file mode 100644 --- /dev/null +++ b/tests/T917.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module T917 where + +import Control.Lens +import Data.Proxy + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +import Data.Kind +#endif + +-- Like Data.Functor.Const, but redfined 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 -> *) (b :: k -> *) = MkT917OneA +data T917OneB a b = MkT917OneB (T917OneA a (Const b)) +$(makePrisms ''T917OneB) + +data T917TwoA (a :: k -> *) (b :: k -> *) = MkT917TwoA +data T917TwoB a b = MkT917TwoB (T917TwoA a (Const b)) +$(makeClassyPrisms ''T917TwoB) + +data family T917DataFam (a :: k) +data instance T917DataFam (a :: *) = MkT917DataFam { _unT917DataFam :: Proxy a } +$(makeLenses 'MkT917DataFam) + +#if __GLASGOW_HASKELL__ >= 800 +data T917GadtOne (a :: k) where + MkT917GadtOne :: T917GadtOne (a :: *) +$(makePrisms ''T917GadtOne) + +data T917GadtTwo (a :: k) where + MkT917GadtTwo :: T917GadtTwo (a :: *) +$(makePrisms ''T917GadtTwo) +#endif diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -7,19 +7,13 @@ -- 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 +-- This module exists to add dependencies ----------------------------------------------------------------------------- module Main where -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - main :: IO () main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources + 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/hunit.hs b/tests/hunit.hs --- a/tests/hunit.hs +++ b/tests/hunit.hs @@ -2,11 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -#if __GLASGOW_HASKELL__ < 706 --- Needed to avoid spurious warnings on GHC 7.4 due to an old TH bug -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ----------------------------------------------------------------------------- -- | -- Module : Main (hunit) @@ -28,8 +23,9 @@ import Control.Lens import Control.Monad.State import Data.Char -import Data.List as List -import Data.Map as Map +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif @@ -80,8 +76,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 } } } @@ -254,18 +250,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) diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -6,12 +6,10 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Main (properties) @@ -36,9 +34,7 @@ import Data.Char (isAlphaNum, isAscii, toUpper) import Data.Text.Strict.Lens import Data.List.Lens -#if __GLASGOW_HASKELL__ >= 708 import GHC.Exts (Constraint) -#endif import Numeric (showHex, showOct, showSigned) import Numeric.Lens import Control.Lens.Properties (isIso, isLens, isPrism, isSetter, isTraversal) @@ -114,15 +110,12 @@ isValidChar c = isAscii c && isAlphaNum c -- Things that should typecheck but that we don't need to run -#if __GLASGOW_HASKELL__ >= 708 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 -#endif -#if __GLASGOW_HASKELL__ >= 706 samplePolyEquality :: Equality Monad Identity Monad Identity samplePolyEquality f = f @@ -134,13 +127,7 @@ 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 -#else -lessSimple :: Equality a b a b -lessSimple f = f -equalityAnEquality :: Equality s t a b -> AnEquality s t a b -equalityAnEquality f = f -#endif equalityIso :: Equality s t a b -> Iso s t a b equalityIso f = f diff --git a/tests/templates.hs b/tests/templates.hs --- a/tests/templates.hs +++ b/tests/templates.hs @@ -27,6 +27,7 @@ import Control.Lens -- import Test.QuickCheck (quickCheck) import T799 () +import T917 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar @@ -312,7 +313,6 @@ 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 } |] @@ -323,8 +323,6 @@ checkFm1 :: Lens' (Family Int (a, b) a) Int checkFm1 = fm1 -#endif - class Class a where data Associated a method :: a -> Int @@ -342,7 +340,6 @@ checkMochi :: Iso' (Associated Int) Double checkMochi = mochi -#if __GLASGOW_HASKELL__ >= 706 declareFields [d| data DeclaredFields f a = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int } @@ -367,7 +364,6 @@ checkC0' :: Traversal' (DeclaredFields f a) String checkC0' = c0 -#endif declareFields [d| data Aardvark = Aardvark { aardvarkAlbatross :: Int } 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