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: [-XCPP, --cpp-ansi, --cpp-include=include] - ignore: {name: Reduce duplication} - ignore: {name: Redundant lambda} @@ -10,17 +10,13 @@ - 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.At, Control.Lens.Zoom, Control.Lens.Equality, Control.Lens.Traversal]} # Breaks code +- ignore: {name: Use id, within: [Control.Lens.Equality]} - ignore: {name: Use camelCase, within: [Control.Lens.Internal.TH]} - ignore: {name: Use list comprehension, within: [Control.Lens.Internal.FieldTH]} -- ignore: {name: Use fmap, within: [Control.Exception.Lens]} # 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} +- ignore: {name: Fuse concatMap/<&>, within: [Control.Lens.Internal.FieldTH]} -- 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,272 @@ +5.3.6 [2026.01.10] +------------------ +* Allow building with `template-haskell-2.24.*` (GHC 9.14). +* Add `_SpecialiseEP` to `Language.Haskell.TH.Lens` (when building with + `template-haskell-2.24.*`/GHC 9.14 or later). + +5.3.5 [2025.06.17] +------------------ +* Replace `test-framework` with `tasty` in the test suite. + +5.3.4 [2025.03.03] +------------------ +* Reduce the arity of `foldr1Of`, `foldl1Of`, `foldrOf'`, `foldlOf'`, + `foldr1Of'`, `foldl1Of'`, `foldrMOf`, and `foldlMOf` so that GHC is more + eager to inline them. On a simple benchmark involving `sumOf` (defined in + terms of `foldlOf'`), this improves performance by 8x. +* Add `Ixed`, `Cons`, `Each`, `AsEmpty`, `Reversing`, and `Rewrapped` instances + for strict boxed vectors when building with `vector-0.13.2` or later. +* Add an `AsEmpty` instance for primitive `Vector`s. + +5.3.3 [2024.12.28] +------------------ +* Add `makeFieldsId`, which generates overloaded field accessors using the + same names as the underlying fields. This is intended for use with the + `NoFieldSelectors` and `DuplicateRecordFields` language extensions. + + Also add `classIdFields :: LensRules` and `classIdNamer :: FieldNamer`, both + of which use the same naming rules as `makeFieldsId`. +* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to + `template-haskell-2.23.0.0`: + * Add an `_OrP` `Prism` for the `Pat` data type. + * Add `_ForallE`, `_ForallVisE`, and `_ConstrainedE` `Prism`s for the `Exp` + data type. + +5.3.2 [2024.05.12] +------------------ +* Define the following lenses that perform an operation and result the old + result: + * `(<<<>:~)` (prepend to the front via `(<>)` and return the old result) + * `(<<<|~)` (prepend to the front via `(<|)` and return the old result) + * `(<<|>~)` (append to the back via `(|>)` and return the old result) + + Each of these also has a variant that end with `=` instead of `~` (e.g., + `(<<<>:=)`) for working in a `MonadState` setting. +* Re-export `(<>:~)`, `(<<>:~)`, `(<|~)`, `(<<|~)`, `(|>~)`, and `(<|>~)` (as + well as their variants which end with `=` instead of `~`, and their variants + which return the old result) from `Control.Lens.Operators`. + +5.3.1 [2024.05.05] +------------------ +* Add a `Magnify` instance for the CPS variant of `RWST` when building with + `mtl-2.3` or later. + +5.3 [2024.05.04] +---------------- +* Allow building with GHC 9.10. +* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to + `template-haskell-2.22.0.0`: + * The `_InfixD` `Prism` now focuses on `(Fixity, NamespaceSpecifier, Name)` + when building with `template-haskell-2.22.0.0` or later. + * Add `Prism`s for the newly introduced `NamespaceSpecifier` data type. + * Add `_TypeP` and `_InvisP` `Prism`s for the `Pat` data type. + * Add a `_TypeE` `Prism` for the `Exp` data type. + * Add a `_SCCP` `Prism` for the `Pragma` data type. +* Add the following `Setter`s for prepending and appending elements: + * `(<>:~)`: prepend an element to the front via `(<>)`. + * `(<<>:~)`: prepend an element to the front via `(<>)` and return the result. + * `(<|~)`: cons an element to the front via `(<|)`. + * `(<<|~)`: cons an element to the front via `(<|)` and return the result. + * `(|>~)`: snoc an element to the back via `(|>)`. + * `(<|>~)`: snoc an element to the back via `(|>)` and return the result. + + Each of these also has a variant that end with `=` instead of `~` (e.g., + `(<>:=)`) for working in a `MonadState` setting. + +5.2.3 [2023.08.24] +------------------ +* Allow building with GHC 9.8. +* Add new `Prism`s to `Language.Haskell.TH.Lens` to reflect recent additions to + `template-haskell`: + * `_GetFieldE` and `_ProjectionE` `Prism`s for the `Exp` data type, whose + corresponding data constructors were introduced in + `template-haskell-2.18.*`. + * `_TypedBracketE` and `_TypedSpliceE` `Prism`s for the `Exp` data type, whose + corresponding data constructors were introduced in + `template-haskell-2.21.*`. + * `_BndrReq` and `_BndrInvis` `Prism`s for the `BndrVis` data type, which was + added in `template-haskell-2.21.*`. +* Add a `generateRecordSyntax` option to `Control.Lens.TH`, which controls + whether to generate lenses using record update syntax or not. By default, this + option is disabled. +* Fix a bug in which the `declare*` Template Haskell functions would fail if a + data type's field has a type that is defined in the same Template Haskell + quotation. +* Add `altOf`, which collects targets into any `Alternative`. + +5.2.2 [2023.03.18] +------------------ +* Fix a bug in which calling `ix i` (where `i` is a negative number) on `Text` + or `ByteString` would return the `Just` the first character instead of + returning `Nothing`. + +5.2.1 [2023.02.27] +------------------ +* Allow building with GHC 9.6. +* Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, + such as the WASM backend. +* Support building with `th-abstraction-0.5.*`. +* Define `_TypeDataD` in `Language.Haskell.TH.Lens` when building with + `template-haskell-2.20.0.0` (GHC 9.6) or later. + +5.2 [2022.08.11] +---------------- +* Allow building with GHC 9.4. +* The type of `universeOf` has changed: + + ```diff + -universeOf :: Getting [a] a a -> a -> [a] + +universeOf :: Getting (Endo [a]) a a -> a -> [a] + ``` + + In many cases, using `Endo [a]` over `[a]` improves performance. Most call + sites to `universeOf` will not be affected by this change, although you may + need to update your code if you define your own combinators in terms of + `universeOf`. +* Allow `makeWrapped` to accept the names of data constructors. This way, + `makeWrapped` can be used with data family instances, much like other + functions in `Control.Lens.TH`. +* Define `_OpaqueP`, `_DefaultD`, `_LamCasesE`, `_PromotedInfixT`, and + `_PromotedUInfixT` in `Language.Haskell.TH.Lens` when building with + `template-haskell-2.19.0.0` (GHC 9.4) or later. + +5.1.1 [2022.05.17] +------------------ +* Add `Data.HashSet.Lens.hashMap`, an `Iso` between a `HashSet a` and a + `HashMap a ()`. +* Allow building with `transformers-0.6.*` and `mtl-2.3.*`. + + Note that `lens` no longer defines `Zoom` instances for `ErrorT` or `ListT` + when building with `mtl-2.3` or later. This is because `MonadState` is a + superclass of `Zoom`, and the `MonadState` instances for `ErrorT` and `ListT` + were removed in `mtl-2.3`. Be watchful of this if you build `lens` with + `mtl-2.3` (or later) combined with an older version of `transformers` + (pre-`0.6`) that defines `ErrorT` or `ListT`. + +5.1 [2021.11.15] +---------------- +* Allow building with GHC 9.2. +* Drop support for GHC 7.10 and older. +* The type of `_ConP` in `Language.Haskell.TH.Lens` is now + `Prism' Pat (Name, [Type], [Pat])` instead of `Prism' Pat (Name, [Pat])` + when building with `template-haskell-2.18` or later. +* Define `_CharTyLit` in `Language.Haskell.TH.Lens` when building with + `template-haskell-2.18` or later. +* Add `Prefixed` and `Suffixed` classes to `Control.Lens.Prism`, which provide + `prefixed` and `suffixed` prisms for prefixes and suffixes of sequence types. + These classes generalize the `prefixed` and `suffixed` functions in + `Data.List.Lens`, which were previously top-level functions. In addition to + providing `Prefixed` and `Suffixed` instances for lists, instances for `Text` + and `ByteString` types are also provided. + + At present, `Prefixed` and `Suffixed` are re-exported from `Data.List.Lens` + for backwards compatibility. This may change in a future version of `lens`, + however. +* Add a `traversal` function to `Control.Lens.Traversal`. This function, aside + from acting as a `Traversal` counterpart to the `lens` and `prism` functions, + provides documentation on how to define `Traversal`s. +* Add a `matching'` function to `Control.Lens.Prism`. `matching'` is like + `matching`, but with a slightly more general type signature that allows it to + work with combinations of `Lens`es, `Prism`s, and `Traversal`s. + +5.0.1 [2021.02.24] +------------------ +* Fix a bug in which `makeLenses` could produce ill kinded optics for + poly-kinded datatypes in certain situations. + +5 [2021.02.17] +-------------- +* Support building with GHC 9.0. +* Remove the `Swapped` type class in favor of `Swap` from the `assoc` package. +* Remove the `Strict` type class in favor of `Strict` from the `strict` package. + + The `swapped`, `strict` and `lazy` isomorphisms are now defined using "new" type classes. + + Users which define own instances of old type classes are advised to + define instances of the new ones. + + ```haskell + import qualified Data.Bifunctor.Swap as Swap + import qualified Control.Lens as Lens + + instance Swap.Swap MyType where + swap = ... + + #if !MIN_VERSION_lens(4,20,0) + instance Lens.Swapped MyType where + swapped = iso Swap.swap Swap.swap + #endif + ``` +* The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type classes + have been migrated to a new package, + [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable). + + The `imapped`, `ifolded` and `itraversed` methods are now top-level functions. + If you are not defining these methods in your instances, + you don't need to change your definitions. + + Beware: the `optics-core` package (versions <0.4) defines similar classes, + and will also migrate to use `indexed-traversable` classes. Therefore, you + might get duplicate instance errors if your package defines both. + + If you define your own `FunctorWithIndex` etc. instances, + we recommend that you depend directly on the `indexed-traversable` package. + If you want to continue support `lens-4` users, you may write + + ```haskell + -- from indexed-traversable + import Data.Functor.WithIndex + + -- from lens + import qualified Control.Lens as L + + -- your (indexed) container + data MySeq a = ... + + -- indexed-traversable instance + instance FunctorWithIndex Int MySeq where imap = ... + instance FoldableWithIndex Int MySeq where ifoldMap = ... + instance TraversableWithIndex Int MySeq where itraverse = ... + + -- lens <5 instance, note the ! + #if !MIN_VERSION_lens(5,0,0) + instance L.FunctorWithIndex Int MySeq where imap = imap + instance L.FoldableWithIndex Int MySeq where ifoldMap = ifoldMap + instance L.TraversableWithIndex Int MySeq where itraverse = itraverse + #endif + ``` + + In other words, always provide `indexed-traversable` instances. + If your package depends on `lens` and allows `lens-4`, + you should additionally provide instances for `lens-4` type classes + that can reuse the `indexed-traversable` instances. + +* Make the functions in `Control.Lens.TH` work more robustly with poly-kinded + data types. This can cause a breaking change under certain situations: + * TH-generated optics for poly-kinded data types are now much more likely to + mention kind variables in their definitions, which will require enabling + the `PolyKinds` extension at use sites in order to typecheck. + * Because TH-generated optics now quantify more kind variables than they did + previously, this can affect the order of visible type applications. +* Generalize the types of `generic` and `generic1` to allow type-changing + updates. If you wish to use the old, more restricted types of these + functions, use `simple . generic` or `simple . generic1` instead. +* Add `Control.Lens.Profunctor` with conversion functions to and from + profunctor optic representation. +* Add `Control.Lens.Review.reviewing`, which is like `review` but with a more + polymorphic type. +* Mark `Control.Lens.Equality` as Trustworthy. +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. +* Use `alterF` in `At (HashMap k)` instance implementation. +* Use `alterF` in `At` and `Contains` instances for `Set`, `IntSet`, and + `HashSet`. +* Avoid re-inserting keys already present in `ix` for `Set`, `IntSet`, + and `HashSet`. For `Set` and `HashSet`, this changes the semantics + slightly; if the user-supplied key is `==` to one already present in + the set, then the latter will not be replaced in the result. +* Consume `()` values lazily in `Control.Lens.At`. + 4.19.2 [2020.04.15] ------------------- * Remove the test suite's dependency on `test-framework-th`. 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). @@ -9,7 +9,7 @@ The [FAQ](https://github.com/ekmett/lens/wiki/FAQ), which provides links to a large number of different resources for learning about lenses and an overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [overview](https://github.com/ekmett/lens/wiki/Overview) and some [examples](https://github.com/ekmett/lens/wiki/Examples). -Documentation is available through [github](http://ekmett.github.com/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. +Documentation is available through [github](https://ekmett.github.io/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. Field Guide ----------- @@ -203,19 +203,30 @@ 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. There are also a couple of hundred examples distributed throughout the haddock documentation. @@ -225,6 +236,6 @@ Contributions and bug reports are welcome! -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. +Please feel free to contact me through GitHub or on the [#haskell-lens](https://web.libera.chat/#haskell-lens) or [#haskell](https://web.libera.chat/#haskell) IRC channel on Libera Chat. -Edward Kmett diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,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/alongside.hs b/benchmarks/alongside.hs --- a/benchmarks/alongside.hs +++ b/benchmarks/alongside.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Main (main) where diff --git a/benchmarks/folds.hs b/benchmarks/folds.hs --- a/benchmarks/folds.hs +++ b/benchmarks/folds.hs @@ -31,6 +31,10 @@ [ bench "native" $ nf (V.toList . V.indexed) v , bench "itraversed" $ nf (itoListOf itraversed) v ] + , bgroup "sum" + [ bench "native" $ whnf V.sum v + , bench "each" $ whnf (sumOf each) v + ] ] , bgroup "unboxed-vector" [ bgroup "toList" @@ -41,6 +45,10 @@ [ bench "native" $ nf (U.toList . U.indexed) u , bench "vTraverse" $ nf (itoListOf vectorTraverse) u ] + , bgroup "sum" + [ bench "native" $ whnf U.sum u + , bench "each" $ whnf (sumOf each) u + ] ] , bgroup "sequence" [ bgroup "toList" @@ -71,6 +79,10 @@ , bgroup "itoList" [ bench "native" $ nf (zip [(0::Int)..]) l , bench "itraversed" $ nf (itoListOf itraversed) l + ] + , bgroup "sum" + [ bench "native" $ whnf sum l + , bench "each" $ whnf (sumOf each) l ] ] , bgroup "map" diff --git a/benchmarks/plated.hs b/benchmarks/plated.hs --- a/benchmarks/plated.hs +++ b/benchmarks/plated.hs @@ -4,13 +4,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Main (main) where -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -import Prelude () -import Prelude.Compat - import Control.Lens import Control.DeepSeq import Criterion.Main @@ -30,7 +23,7 @@ | Sub !Expr !Expr | Mul !Expr !Expr | Div !Expr !Expr - deriving (Eq,Show,Data,Typeable,Generic) + deriving (Eq,Show,Data,Generic) instance NFData Expr where rnf (Neg a) = rnf a @@ -70,6 +63,8 @@ , bench "universeOf Data.template" $ nf (map (universeOf Data.template)) testsExpr , bench "universeOf Data.uniplate" $ nf (map (universeOf Data.uniplate)) testsExpr , bench "universeOf (cloneTraversal plate)" $ nf (map (universeOf (cloneTraversal plate))) testsExpr + , bench "universeOf plate fibExpr" $ nf (universeOf plate) fibExpr + , bench "universeOf Data.uniplate fibExpr" $ nf (universeOf Data.uniplate) fibExpr #ifdef BENCHMARK_UNIPLATE , bench "Direct.universe" $ nf (map Uni.universe) testsExpr , bench "DataOnly.universe" $ nf (map UniDataOnly.universe) testsExpr @@ -78,3 +73,8 @@ testsExpr :: [Expr] testsExpr = [Val 3,Val 2,Val 6,Neg (Neg (Var "dus")),Mul (Div (Add (Val 4) (Var "kxm")) (Sub (Mul (Div (Var "") (Var "")) (Var "w")) (Var "ed"))) (Var "whpd"),Val 6,Val 4,Val 2,Var "a",Val 1,Div (Var "") (Val 0),Var "",Var "",Val (-3),Val 3,Sub (Var "") (Val 2),Neg (Var "dlp"),Div (Val 0) (Var "sd"),Val (-2),Val (-3),Var "g",Mul (Val 3) (Var "i"),Val 1,Var "ul",Div (Add (Var "") (Var "")) (Mul (Div (Val 0) (Neg (Val 0))) (Neg (Neg (Mul (Var "") (Val 0))))),Var "z",Sub (Neg (Add (Var "") (Val 0))) (Var ""),Neg (Sub (Mul (Val 0) (Val 2)) (Val 5)),Val 0,Val 0,Mul (Val (-4)) (Sub (Val 5) (Neg (Div (Div (Val 0) (Sub (Neg (Sub (Val (-3)) (Mul (Mul (Var "ap") (Val 3)) (Add (Add (Add (Var "owre") (Add (Add (Var "avj") (Val 3)) (Var "vhi"))) (Mul (Val 2) (Var "hak"))) (Val 2))))) (Var "nf"))) (Add (Sub (Val 5) (Sub (Var "pkjyh") (Val 2))) (Var "lsiu"))))),Var "u",Val 1,Neg (Add (Add (Var "") (Val 1)) (Sub (Add (Add (Val (-3)) (Mul (Val 1) (Var "pfe"))) (Var "yv")) (Mul (Var "") (Var "jfq")))),Val 2,Div (Div (Div (Div (Var "xrgykq") (Mul (Var "kyfu") (Val 2))) (Sub (Var "v") (Val 0))) (Sub (Val 6) (Val 2))) (Val 3),Var "",Var "",Add (Var "ob") (Sub (Mul (Neg (Val 2)) (Val 6)) (Add (Mul (Val 6) (Sub (Add (Var "wue") (Mul (Var "hgsuj") (Neg (Div (Var "hr") (Var "ozvsb"))))) (Sub (Var "j") (Div (Var "yeyhvq") (Val (-6)))))) (Var "b"))),Div (Add (Div (Div (Neg (Val 4)) (Var "")) (Var "yfx")) (Div (Sub (Var "") (Sub (Var "np") (Mul (Val 3) (Var "mxr")))) (Mul (Var "m") (Var "kkhbf")))) (Neg (Sub (Var "yie") (Val 1))),Neg (Var ""),Var "liuh",Var "pbqg",Var "",Neg (Div (Sub (Add (Val (-1)) (Var "onynvr")) (Neg (Var "tqjsay"))) (Add (Val 4) (Var "yorkb"))),Val 1,Add (Mul (Neg (Div (Val (-1)) (Var "u"))) (Sub (Var "") (Neg (Val 1)))) (Var "h"),Var "",Add (Mul (Sub (Var "em") (Val 0)) (Add (Val (-2)) (Val 1))) (Var ""),Add (Mul (Add (Div (Add (Val 0) (Mul (Mul (Var "e") (Add (Val 1) (Var ""))) (Neg (Neg (Div (Add (Div (Neg (Val 1)) (Div (Val (-1)) (Mul (Add (Div (Val (-1)) (Mul (Mul (Val 1) (Val 1)) (Mul (Var "t") (Val (-1))))) (Val 1)) (Val 1)))) (Add (Neg (Add (Val 0) (Var "k"))) (Mul (Neg (Div (Sub (Sub (Var "u") (Val 1)) (Val 1)) (Sub (Neg (Var "")) (Sub (Var "b") (Val (-1)))))) (Neg (Var ""))))) (Val 0)))))) (Val 0)) (Var "a")) (Var "")) (Val (-1)),Var "xijsnp",Div (Var "h") (Neg (Val 5)),Div (Var "dmzlh") (Add (Val 6) (Val (-2))),Neg (Add (Val 0) (Var "")),Add (Add (Add (Sub (Val 4) (Var "nfse")) (Var "o")) (Add (Val 2) (Div (Var "mtqdx") (Val (-3))))) (Val 3),Neg (Var "c"),Var "sr",Mul (Add (Sub (Neg (Val 1)) (Sub (Div (Add (Sub (Add (Sub (Sub (Var "gd") (Mul (Var "v") (Var "d"))) (Var "")) (Val 1)) (Add (Val 2) (Var ""))) (Var "kk")) (Div (Var "fw") (Add (Val 1) (Var "f")))) (Var ""))) (Val 2)) (Add (Neg (Div (Var "") (Val 0))) (Add (Var "") (Add (Var "s") (Add (Mul (Var "") (Val (-1))) (Val 1))))),Val 1,Var "",Sub (Var "vbnzahx") (Val (-5)),Var "nl",Val 0,Add (Mul (Neg (Mul (Var "") (Var "mvil"))) (Var "")) (Neg (Var "zxl")),Val (-3),Var "",Var "e",Add (Div (Sub (Val 0) (Add (Val 5) (Val 7))) (Mul (Var "") (Var "qz"))) (Val 4),Add (Val (-1)) (Neg (Var "lk")),Add (Add (Var "u") (Mul (Val 1) (Var "h"))) (Sub (Mul (Div (Val 1) (Div (Var "t") (Neg (Var "")))) (Var "")) (Mul (Val 1) (Neg (Div (Neg (Var "")) (Var ""))))),Val 0,Val 0,Val (-7),Mul (Var "") (Val 0),Mul (Add (Val (-6)) (Add (Val 2) (Sub (Div (Var "z") (Var "gbb")) (Var "vddnpsl")))) (Add (Add (Add (Var "") (Sub (Div (Val 3) (Neg (Div (Add (Var "cfvgz") (Add (Sub (Var "htd") (Sub (Var "mhbl") (Var "un"))) (Val 3))) (Val (-3))))) (Var ""))) (Val 5)) (Neg (Mul (Val 0) (Var "sufvvj")))),Sub (Div (Neg (Add (Add (Neg (Add (Var "") (Val 0))) (Var "")) (Sub (Val 0) (Val 0)))) (Val 0)) (Add (Neg (Div (Div (Add (Sub (Add (Add (Neg (Var "")) (Val 0)) (Val 0)) (Add (Neg (Add (Neg (Var "")) (Neg (Val 0)))) (Val 0))) (Div (Val 0) (Val 0))) (Val 0)) (Val 0))) (Var "")),Var "",Sub (Div (Val 0) (Div (Add (Val 1) (Neg (Div (Neg (Var "y")) (Val 0)))) (Var ""))) (Sub (Div (Var "t") (Var "")) (Neg (Var "s"))),Mul (Div (Sub (Var "") (Var "")) (Add (Val 0) (Sub (Div (Var "yr") (Neg (Var "o"))) (Val 1)))) (Var "u"),Var "odmn",Div (Var "uddqy") (Val 3),Var "",Sub (Val 2) (Neg (Val (-1))),Div (Mul (Var "sox") (Val (-3))) (Val (-3)),Var "qv",Var "xmbnts",Var "j",Mul (Val 6) (Mul (Var "fryndq") (Neg (Val 6))),Var "",Var "",Val (-1),Val 7,Add (Var "dg") (Val 1),Neg (Val 1),Val 0,Var "xnm",Sub (Div (Div (Var "miwi") (Var "mbh")) (Val 3)) (Val 3),Neg (Val (-4)),Var "ndubxoa",Var ""] + +fibExpr :: Expr +fibExpr = go 11 where + go :: Int -> Expr + go n = if n <= 1 then Val 1 else Add (go (n - 1)) (go (n - 2)) diff --git a/benchmarks/traversals.hs b/benchmarks/traversals.hs --- a/benchmarks/traversals.hs +++ b/benchmarks/traversals.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where import qualified Data.ByteString as BS @@ -19,27 +19,6 @@ import Control.Lens 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/Plates.hs b/examples/Plates.hs --- a/examples/Plates.hs +++ b/examples/Plates.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} module Plates where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif import Control.Lens import GHC.Generics import Data.Data -data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) -data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) +data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data) +data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data) instance Plated Expr where plate _ (Var x ) = pure (Var x) diff --git a/examples/Pong.hs b/examples/Pong.hs --- a/examples/Pong.hs +++ b/examples/Pong.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- | -- Module : Main @@ -12,9 +12,6 @@ ----------------------------------------------------------------------------- module Main where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -#endif import Control.Lens hiding ((:>), at) import Control.Monad.State (State, execState, get) import Control.Monad (when) diff --git a/examples/lens-examples.cabal b/examples/lens-examples.cabal --- a/examples/lens-examples.cabal +++ b/examples/lens-examples.cabal @@ -16,20 +16,24 @@ Pong Example build-type: Simple -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 source-repository head type: git - location: git://github.com/ekmett/lens.git + location: https://github.com/ekmett/lens.git flag pong default: True @@ -41,10 +45,9 @@ Turtle build-depends: aeson, - base >= 4.5 && < 5, - bytestring >= 0.9.1.10 && < 0.11, + base >= 4.9 && < 5, + bytestring >= 0.9.1.10 && < 0.13, data-default-class, - ghc-prim, lens default-language: Haskell2010 ghc-options: -Wall @@ -54,12 +57,12 @@ buildable: False build-depends: - base >= 4.5 && < 5, - containers >= 0.4 && < 0.7, + base >= 4.9 && < 5, + containers >= 0.4 && < 0.9, gloss >= 1.12 && < 1.14, lens, - mtl >= 2.0.1 && < 2.3, - random >= 1.0 && < 1.2, + mtl >= 2.0.1 && < 2.4, + random >= 1.0 && < 1.4, streams >= 3.3 && < 4 main-is: Pong.hs default-language: Haskell2010 diff --git a/include/lens-common.h b/include/lens-common.h --- a/include/lens-common.h +++ b/include/lens-common.h @@ -19,32 +19,8 @@ #define MIN_VERSION_containers(x,y,z) 1 #endif -#ifndef MIN_VERSION_exceptions -#define MIN_VERSION_exceptions 1 -#endif - -#ifndef MIN_VERSION_free -#define MIN_VERSION_free(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_parallel -#define MIN_VERSION_parallel(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL > 700) -#endif - -#ifndef MIN_VERSION_reflection -#define MIN_VERSION_reflection(x,y,z) 1 -#endif - #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 #endif #endif 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/CHANGELOG.markdown b/lens-properties/CHANGELOG.markdown --- a/lens-properties/CHANGELOG.markdown +++ b/lens-properties/CHANGELOG.markdown @@ -1,3 +1,7 @@ +next [????.??.??] +----------------- +* Drop support for GHC 7.10 and older. + 4.11.1 ------ * Update version bounds. 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,16 +13,20 @@ 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 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 extra-source-files: .hlint.yaml @@ -30,17 +34,18 @@ source-repository head type: git - location: git://github.com/ekmett/lens.git + location: https://github.com/ekmett/lens.git library build-depends: - base >= 4.5 && < 5, - lens >= 4 && < 5, - QuickCheck >= 2.4 && < 2.15, - transformers >= 0.2 && < 0.6 + base >= 4.9 && < 5, + lens >= 4 && < 6, + QuickCheck >= 2.4 && < 2.18, + transformers >= 0.2 && < 0.7 exposed-modules: Control.Lens.Properties hs-source-dirs: src ghc-options: -Wall + default-language: Haskell2010 diff --git a/lens-properties/src/Control/Lens/Properties.hs b/lens-properties/src/Control/Lens/Properties.hs --- a/lens-properties/src/Control/Lens/Properties.hs +++ b/lens-properties/src/Control/Lens/Properties.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,9 +12,6 @@ , isPrism ) where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif import Control.Lens import Data.Functor.Compose import Test.QuickCheck 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.3.6 license: BSD2 cabal-version: 1.18 license-file: LICENSE @@ -10,18 +10,22 @@ 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 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types @@ -34,7 +38,7 @@ . An overview, with a large number of examples can be found in the . . - An introductory video on the style of code used in this library by Simon Peyton Jones is available from . + An introductory video on the style of code used in this library by Simon Peyton Jones is available from . . A video on how to use lenses and how they are constructed is available on . . @@ -50,9 +54,7 @@ With some signatures simplified, the core of the hierarchy of lens-like constructions looks like: . . - <> - . - + <> . You can compose any two elements of the hierarchy above using @(.)@ from the @Prelude@, and you can use any element of the hierarchy as any type it linked to above it. @@ -97,7 +99,6 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). extra-source-files: - .travis.yml .gitignore .hlint.yaml .vim.custom @@ -113,9 +114,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 +125,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 +143,11 @@ manual: True default: True --- Some 7.6.1-rc1 users report their TH still uses old style inline pragmas. This lets them turn on inlining. -flag old-inline-pragmas - default: False - manual: True - -- Make the test suites dump their template-haskell splices. flag dump-splices default: False manual: True --- You can disable the 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 +162,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,53 +174,45 @@ 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, - 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 - - if !impl(ghc >= 8.0) - build-depends: - generic-deriving >= 1.10 && < 2, - semigroups >= 0.8.4 && < 1 - - if !impl(ghc >= 7.10) - build-depends: - nats >= 0.1 && < 1.2, - void >= 0.5 && < 1 + array >= 0.5.0.0 && < 0.6, + assoc >= 1.0.2 && < 1.2, + base >= 4.9 && < 5, + base-orphans >= 0.5.2 && < 1, + bifunctors >= 5.5.7 && < 6, + bytestring >= 0.10.4.0 && < 0.13, + call-stack >= 0.1 && < 0.5, + comonad >= 5.0.7 && < 6, + containers >= 0.5.5.1 && < 0.9, + contravariant >= 1.4 && < 2, + distributive >= 0.5.1 && < 1, + exceptions >= 0.8.2.1 && < 1, + filepath >= 1.2.0.0 && < 1.6, + free >= 5.1.5 && < 6, + hashable >= 1.2.7.0 && < 1.6, + indexed-traversable >= 0.1 && < 0.2, + indexed-traversable-instances >= 0.1 && < 0.2, + kan-extensions >= 5 && < 6, + mtl >= 2.2.1 && < 2.4, + parallel >= 3.2.1.0 && < 3.4, + profunctors >= 5.5.2 && < 6, + reflection >= 2.1 && < 3, + semigroupoids >= 5.0.1 && < 7, + strict >= 0.4 && < 0.6, + tagged >= 0.8.6 && < 1, + template-haskell >= 2.11.1.0 && < 2.25, + text >= 1.2.3.0 && < 2.2, + th-abstraction >= 0.4.1 && < 0.8, + these >= 1.1.1.1 && < 1.3, + transformers >= 0.5.0.0 && < 0.7, + unordered-containers >= 0.2.10 && < 0.3, + vector >= 0.12.1.2 && < 0.14 - 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 @@ -258,10 +226,10 @@ Control.Lens.Internal Control.Lens.Internal.Bazaar Control.Lens.Internal.ByteString - Control.Lens.Internal.Coerce Control.Lens.Internal.Context Control.Lens.Internal.CTypes Control.Lens.Internal.Deque + Control.Lens.Internal.Doctest Control.Lens.Internal.Exception Control.Lens.Internal.FieldTH Control.Lens.Internal.PrismTH @@ -274,10 +242,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 +253,7 @@ Control.Lens.Operators Control.Lens.Plated Control.Lens.Prism + Control.Lens.Profunctor Control.Lens.Reified Control.Lens.Review Control.Lens.Setter @@ -329,35 +298,19 @@ other-modules: 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 - - if impl(ghc >= 8) - 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 + ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10 + -Wno-trustworthy-safe -Wmissing-pattern-synonym-signatures -Wno-redundant-constraints hs-source-dirs: src @@ -365,11 +318,22 @@ 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: + BigRecord + T799 + T917 + T972 + if impl(ghc >= 9.2) + other-modules: + T1024 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 @@ -400,9 +364,9 @@ build-depends: base, lens, - QuickCheck >= 2.4, - test-framework >= 0.6, - test-framework-quickcheck2 >= 0.2, + QuickCheck >= 2.4, + tasty >= 1.4 && < 1.6, + tasty-quickcheck >= 0.10 && < 0.12, transformers test-suite hunit @@ -418,46 +382,24 @@ build-depends: base, containers, - HUnit >= 1.2, lens, mtl, - test-framework >= 0.6, - test-framework-hunit >= 0.2 + text, + bytestring, + tasty >= 1.4 && < 1.6, + tasty-hunit >= 0.10 && < 0.11 --- 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 <5, deepseq, simple-reflect >= 0.3.1 -- Basic benchmarks for the uniplate-style combinators benchmark plated @@ -468,7 +410,6 @@ default-language: Haskell2010 build-depends: base, - base-compat >=0.11.0 && <0.12, comonad, criterion, deepseq, diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs --- a/src/Control/Exception/Lens.hs +++ b/src/Control/Exception/Lens.hs @@ -4,22 +4,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -#endif - #include "lens-common.h" -#if !(MIN_VERSION_exceptions(0,4,0)) -#define MonadThrow MonadCatch -#endif - ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens @@ -36,7 +29,7 @@ -- be found in "System.IO.Error.Lens". -- -- The combinators in this module have been generalized to work with --- 'MonadCatch' instead of just 'IO'. This enables them to be used +-- 'MonadCatch' instead of just 'Prelude.IO'. This enables them to be used -- more easily in 'Monad' transformer stacks. ---------------------------------------------------------------------------- module Control.Exception.Lens @@ -55,23 +48,16 @@ , mappedException, mappedException' -- * Exceptions , exception -#if __GLASGOW_HASKELL__ >= 710 , pattern Exception -#endif -- * Exception Handlers , Handleable(..) -- ** IOExceptions , AsIOException(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern IOException_ -#endif -- ** 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_ , pattern Underflow_ @@ -79,108 +65,79 @@ , pattern DivideByZero_ , pattern Denormal_ , pattern RatioZeroDenominator_ -#endif -- ** Array Exceptions , AsArrayException(..) , _IndexOutOfBounds , _UndefinedElement -#if __GLASGOW_HASKELL__ >= 710 , pattern ArrayException_ , pattern IndexOutOfBounds_ , pattern UndefinedElement_ -#endif -- ** Assertion Failed , AsAssertionFailed(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern AssertionFailed__ , pattern AssertionFailed_ -#endif -- ** Async Exceptions , AsAsyncException(..) , _StackOverflow , _HeapOverflow , _ThreadKilled , _UserInterrupt -#if __GLASGOW_HASKELL__ >= 710 , pattern AsyncException_ , pattern StackOverflow_ , pattern HeapOverflow_ , pattern ThreadKilled_ , pattern UserInterrupt_ -#endif -- ** Non-Termination , AsNonTermination(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern NonTermination__ , pattern NonTermination_ -#endif -- ** Nested Atomically , AsNestedAtomically(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern NestedAtomically__ , pattern NestedAtomically_ -#endif -- ** Blocked Indefinitely -- *** on MVar , AsBlockedIndefinitelyOnMVar(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern BlockedIndefinitelyOnMVar__ , pattern BlockedIndefinitelyOnMVar_ -#endif -- *** on STM , AsBlockedIndefinitelyOnSTM(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern BlockedIndefinitelyOnSTM__ , pattern BlockedIndefinitelyOnSTM_ -#endif -- ** Deadlock , AsDeadlock(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern Deadlock__ , pattern Deadlock_ -#endif -- ** No Such Method , AsNoMethodError(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern NoMethodError__ , pattern NoMethodError_ -#endif -- ** Pattern Match Failure , AsPatternMatchFail(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern PatternMatchFail__ , pattern PatternMatchFail_ -#endif -- ** Record , AsRecConError(..) , AsRecSelError(..) , AsRecUpdError(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern RecConError__ , pattern RecConError_ , pattern RecSelError__ , pattern RecSelError_ , pattern RecUpdError__ , pattern RecUpdError_ -#endif -- ** Error Call , AsErrorCall(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern ErrorCall__ , pattern ErrorCall_ -#endif -#if MIN_VERSION_base(4,8,0) -- ** Allocation Limit Exceeded , AsAllocationLimitExceeded(..) , pattern AllocationLimitExceeded__ , pattern AllocationLimitExceeded_ -#endif -#if MIN_VERSION_base(4,9,0) -- ** Type Error , AsTypeError(..) , pattern TypeError__ , pattern TypeError_ -#endif #if MIN_VERSION_base(4,10,0) -- ** Compaction Failed , AsCompactionFailed(..) @@ -189,10 +146,8 @@ #endif -- * Handling Exceptions , AsHandlingException(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern HandlingException__ , pattern HandlingException_ -#endif ) where import Control.Applicative @@ -208,44 +163,45 @@ ( const, either, flip, id , (.) , Maybe(..), Either(..), String -#if __GLASGOW_HASKELL__ >= 710 , Bool(..) -#endif ) -#ifdef HLINT -{-# ANN module "HLint: ignore Use Control.Exception.catch" #-} +{- +$setup +>>> :set -XNoOverloadedStrings +>>> :set -XScopedTypeVariables +>>> import Control.Lens +>>> import Control.Applicative +>>> :m + Control.Exception Control.Monad Data.List Prelude +#if MIN_VERSION_base(4,20,0) +>>> :m + Control.Exception.Context #endif - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :m + Control.Exception Control.Monad Data.List Prelude +-} ------------------------------------------------------------------------------ -- Exceptions as Prisms ------------------------------------------------------------------------------ --- | Traverse the strongly typed 'Exception' contained in 'SomeException' where the type of your function matches --- the desired 'Exception'. +-- | Traverse the strongly typed t'Exception' contained in 'SomeException' where the type of your function matches +-- the desired t'Exception'. -- -- @ --- 'exception' :: ('Applicative' f, 'Exception' a) +-- 'exception' :: ('Applicative' f, t'Exception' a) -- => (a -> f a) -> 'SomeException' -> f 'SomeException' -- @ exception :: Exception a => Prism' SomeException a exception = prism' toException fromException {-# INLINE exception #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Exception :: Exception a => a -> SomeException pattern Exception e <- (preview exception -> Just e) where Exception e = review exception e -#endif ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ --- | Catch exceptions that match a given 'Prism' (or any 'Fold', really). +-- | Catch exceptions that match a given t'Prism' (or any t'Fold', really). -- -- >>> catching _AssertionFailed (assert False (return "uncaught")) $ \ _ -> return "caught" -- "caught" @@ -255,16 +211,16 @@ -- 'catching' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r +-- 'catching' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r +-- 'catching' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r -- @ catching :: MonadCatch m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} --- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding +-- | Catch exceptions that match a given t'Prism' (or any t'Getter'), discarding -- the information about the match. This is particularly useful when you have --- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't +-- a @'Prism'' e ()@ where the result of the t'Prism' or t'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- >>> catching_ _AssertionFailed (assert False (return "uncaught")) $ return "caught" @@ -275,8 +231,8 @@ -- 'catching_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r --- 'catching_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r --- 'catching_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r +-- 'catching_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m r -> m r +-- 'catching_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m r -> m r -- @ catching_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) @@ -297,8 +253,8 @@ -- 'handling' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r +-- 'handling' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r +-- 'handling' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r -- @ handling :: MonadCatch m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l) @@ -315,8 +271,8 @@ -- 'handling_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r --- 'handling_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r --- 'handling_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r +-- 'handling_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m r -> m r +-- 'handling_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m r -> m r -- @ handling_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l) @@ -326,17 +282,17 @@ -- Trying ------------------------------------------------------------------------------ --- | A variant of 'Control.Exception.try' that takes a 'Prism' (or any 'Fold') to select which +-- | A variant of 'Control.Exception.try' that takes a t'Prism' (or any t'Fold') to select which -- exceptions are caught (c.f. 'Control.Exception.tryJust', 'Control.Exception.catchJust'). If the --- 'Exception' does not match the predicate, it is re-thrown. +-- t'Exception' does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m ('Either' a r) --- 'trying' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m ('Either' a r) --- 'trying' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m ('Either' a r) +-- 'trying' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m ('Either' a r) +-- 'trying' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m ('Either' a r) -- @ trying :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Either a r) trying l = tryJust (preview l) @@ -349,8 +305,8 @@ -- 'trying_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m (Maybe r) --- 'trying_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m (Maybe r) --- 'trying_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m (Maybe r) +-- 'trying_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m (Maybe r) +-- 'trying_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m (Maybe r) -- @ trying_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Maybe r) trying_ l m = preview _Right `liftM` trying l m @@ -360,8 +316,8 @@ -- Throwing ------------------------------------------------------------------------------ --- | Throw an 'Exception' described by a 'Prism'. Exceptions may be thrown from --- purely functional code, but may only be caught within the 'IO' 'Monad'. +-- | Throw an t'Exception' described by a t'Prism'. Exceptions may be thrown from +-- purely functional code, but may only be caught within the 'Prelude.IO' 'Monad'. -- -- @ -- 'throwing' l ≡ 'reviews' l 'throw' @@ -381,15 +337,15 @@ -- @ -- data MyError = Foo | Bar -- makePrisms ''MyError --- 'throwing_' _Foo :: 'MonadError' MyError m => m a +-- 'throwing_' _Foo :: 'Control.Monad.Error.Class.MonadError' MyError m => m a -- @ throwing_ :: AReview SomeException () -> m x throwing_ l = throwing l () {-# INLINE throwing_ #-} --- | A variant of 'throwing' that can only be used within the 'IO' 'Monad' --- (or any other 'MonadCatch' instance) to throw an 'Exception' described --- by a 'Prism'. +-- | A variant of 'throwing' that can only be used within the 'Prelude.IO' 'Monad' +-- (or any other 'MonadCatch' instance) to throw an t'Exception' described +-- by a t'Prism'. -- -- Although 'throwingM' has a type that is a specialization of the type of -- 'throwing', the two functions are subtly different: @@ -399,10 +355,10 @@ -- 'throwingM' l e \`seq\` x ≡ x -- @ -- --- The first example will cause the 'Exception' @e@ to be raised, whereas the --- second one won't. In fact, 'throwingM' will only cause an 'Exception' to +-- The first example will cause the t'Exception' @e@ to be raised, whereas the +-- second one won't. In fact, 'throwingM' will only cause an t'Exception' to -- be raised when it is used within the 'MonadCatch' instance. The 'throwingM' --- variant should be used in preference to 'throwing' to raise an 'Exception' +-- variant should be used in preference to 'throwing' to raise an t'Exception' -- within the 'Monad' because it guarantees ordering with respect to other -- monadic operations, whereas 'throwing' does not. -- @@ -418,7 +374,7 @@ throwingM l = reviews l throwM {-# INLINE throwingM #-} --- | 'throwingTo' raises an 'Exception' specified by a 'Prism' in the target thread. +-- | 'throwingTo' raises an t'Exception' specified by a t'Prism' in the target thread. -- -- @ -- 'throwingTo' thread l ≡ 'reviews' l ('throwTo' thread) @@ -436,14 +392,14 @@ -- Mapping ---------------------------------------------------------------------------- --- | This 'Setter' can be used to purely map over the 'Exception's an +-- | This t'Setter' can be used to purely map over the t'Exception's an -- arbitrary expression might throw; it is a variant of 'mapException' in -- the same way that 'mapped' is a variant of 'fmap'. -- -- > 'mapException' ≡ 'over' 'mappedException' -- -- This view that every Haskell expression can be regarded as carrying a bag --- of 'Exception's is detailed in “A Semantics for Imprecise Exceptions” by +-- of t'Exception's is detailed in “A Semantics for Imprecise Exceptions” by -- Peyton Jones & al. at PLDI ’99. -- -- The following maps failed assertions to arithmetic overflow: @@ -455,7 +411,7 @@ {-# INLINE mappedException #-} -- | This is a type restricted version of 'mappedException', which avoids --- the type ambiguity in the input 'Exception' when using 'set'. +-- the type ambiguity in the input t'Exception' when using 'set'. -- -- The following maps any exception to arithmetic overflow: -- @@ -469,14 +425,14 @@ -- IOException ---------------------------------------------------------------------------- --- | Exceptions that occur in the 'IO' 'Monad'. An 'IOException' records a +-- | Exceptions that occur in the 'Prelude.IO' 'Monad'. An 'IOException' records a -- more specific error type, a descriptive string and maybe the handle that was -- used when the error was flagged. -- -- Due to their richer structure relative to other exceptions, these have -- a more carefully overloaded signature. class AsIOException t where - -- | Unfortunately the name 'ioException' is taken by @base@ for + -- | Unfortunately the name 'GHC.IO.Exception.ioException' is taken by @base@ for -- throwing IOExceptions. -- -- @ @@ -496,10 +452,9 @@ _IOException = exception {-# INLINE _IOException #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern IOException_ :: AsIOException s => IOException -> s pattern IOException_ a <- (preview _IOException -> Just a) where IOException_ a = review _IOException a -#endif ---------------------------------------------------------------------------- -- ArithException @@ -514,10 +469,9 @@ -- @ _ArithException :: Prism' t ArithException -#if __GLASGOW_HASKELL__ >= 710 +pattern ArithException_ :: AsArithException s => ArithException -> s pattern ArithException_ a <- (preview _ArithException -> Just a) where ArithException_ a = review _ArithException a -#endif instance AsArithException ArithException where _ArithException = id @@ -543,10 +497,9 @@ seta t = Left (pure t) {-# INLINE _Overflow #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Overflow_ :: AsArithException s => s pattern Overflow_ <- (has _Overflow -> True) where Overflow_ = review _Overflow () -#endif -- | Handle arithmetic '_Underflow'. -- @@ -564,10 +517,9 @@ seta t = Left (pure t) {-# INLINE _Underflow #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Underflow_ :: AsArithException s => s pattern Underflow_ <- (has _Underflow -> True) where Underflow_ = review _Underflow () -#endif -- | Handle arithmetic loss of precision. -- @@ -585,10 +537,9 @@ seta t = Left (pure t) {-# INLINE _LossOfPrecision #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern LossOfPrecision_ :: AsArithException s => s pattern LossOfPrecision_ <- (has _LossOfPrecision -> True) where LossOfPrecision_ = review _LossOfPrecision () -#endif -- | Handle division by zero. -- @@ -606,10 +557,9 @@ seta t = Left (pure t) {-# INLINE _DivideByZero #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern DivideByZero_ :: AsArithException s => s pattern DivideByZero_ <- (has _DivideByZero -> True) where DivideByZero_ = review _DivideByZero () -#endif -- | Handle exceptional _Denormalized floating pure. -- @@ -627,15 +577,11 @@ seta t = Left (pure t) {-# INLINE _Denormal #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Denormal_ :: AsArithException s => s pattern Denormal_ <- (has _Denormal -> True) where 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' @@ -651,13 +597,10 @@ seta t = Left (pure t) {-# INLINE _RatioZeroDenominator #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern RatioZeroDenominator_ :: AsArithException s => s pattern RatioZeroDenominator_ <- (has _RatioZeroDenominator -> True) where RatioZeroDenominator_ = review _RatioZeroDenominator () -#endif -#endif - ---------------------------------------------------------------------------- -- ArrayException ---------------------------------------------------------------------------- @@ -680,10 +623,9 @@ _ArrayException = exception {-# INLINE _ArrayException #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern ArrayException_ :: AsArrayException s => ArrayException -> s pattern ArrayException_ e <- (preview _ArrayException -> Just e) where ArrayException_ e = review _ArrayException e -#endif -- | An attempt was made to index an array outside its declared bounds. -- @@ -701,10 +643,9 @@ seta t = Left (pure t) {-# INLINE _IndexOutOfBounds #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern IndexOutOfBounds_ :: AsArrayException s => String -> s pattern IndexOutOfBounds_ e <- (preview _IndexOutOfBounds -> Just e) where IndexOutOfBounds_ e = review _IndexOutOfBounds e -#endif -- | An attempt was made to evaluate an element of an array that had not been initialized. -- @@ -722,10 +663,9 @@ seta t = Left (pure t) {-# INLINE _UndefinedElement #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern UndefinedElement_ :: AsArrayException s => String -> s pattern UndefinedElement_ e <- (preview _UndefinedElement -> Just e) where UndefinedElement_ e = review _UndefinedElement e -#endif ---------------------------------------------------------------------------- -- AssertionFailed @@ -740,15 +680,21 @@ -- @ __AssertionFailed :: Prism' t AssertionFailed - -- | This 'Exception' contains provides information about what assertion failed in the 'String'. - -- + {- | This t'Exception' contains provides information about what assertion failed in the 'String'. + + @ + '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String' + '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' + @ + +#if MIN_VERSION_base(4,20,0) + >>> handling exception (\ (ExceptionWithContext ctxt (_ :: AssertionFailed)) -> "caught" <$ guard ("" `isInfixOf` displayExceptionContext ctxt) ) $ assert False (return "uncaught") + "caught" +#else -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("" `isInfixOf` xs) ) $ assert False (return "uncaught") -- "caught" - -- - -- @ - -- '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String' - -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' - -- @ +#endif + -} _AssertionFailed :: Prism' t String _AssertionFailed = __AssertionFailed._AssertionFailed {-# INLINE _AssertionFailed #-} @@ -764,13 +710,13 @@ __AssertionFailed = exception {-# INLINE __AssertionFailed #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern AssertionFailed__ :: AsAssertionFailed s => AssertionFailed -> s pattern AssertionFailed__ e <- (preview __AssertionFailed -> Just e) where AssertionFailed__ e = review __AssertionFailed e +pattern AssertionFailed_ :: AsAssertionFailed s => String -> s pattern AssertionFailed_ e <- (preview _AssertionFailed -> Just e) where AssertionFailed_ e = review _AssertionFailed e -#endif ---------------------------------------------------------------------------- -- AsyncException @@ -794,12 +740,11 @@ _AsyncException = exception {-# INLINE _AsyncException #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern AsyncException_ :: AsAsyncException s => AsyncException -> s pattern AsyncException_ e <- (preview _AsyncException -> Just e) where AsyncException_ e = review _AsyncException e -#endif --- | The current thread's stack exceeded its limit. Since an 'Exception' has +-- | The current thread's stack exceeded its limit. Since an t'Exception' has -- been raised, the thread's stack will certainly be below its limit again, -- but the programmer should take remedial action immediately. -- @@ -813,17 +758,16 @@ seta t = Left (pure t) {-# INLINE _StackOverflow #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern StackOverflow_ :: AsAsyncException s => s pattern StackOverflow_ <- (has _StackOverflow -> True) where StackOverflow_ = review _StackOverflow () -#endif -- | The program's heap is reaching its limit, and the program should take action -- to reduce the amount of live data it has. -- -- Notes: -- --- * It is undefined which thread receives this 'Exception'. +-- * It is undefined which thread receives this t'Exception'. -- -- * GHC currently does not throw 'HeapOverflow' exceptions. -- @@ -837,12 +781,11 @@ seta t = Left (pure t) {-# INLINE _HeapOverflow #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern HeapOverflow_ :: AsAsyncException s => s pattern HeapOverflow_ <- (has _HeapOverflow -> True) where HeapOverflow_ = review _HeapOverflow () -#endif --- | This 'Exception' is raised by another thread calling +-- | This t'Exception' is raised by another thread calling -- 'Control.Concurrent.killThread', or by the system if it needs to terminate -- the thread for some reason. -- @@ -856,12 +799,11 @@ seta t = Left (pure t) {-# INLINE _ThreadKilled #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern ThreadKilled_ :: AsAsyncException s => s pattern ThreadKilled_ <- (has _ThreadKilled -> True) where ThreadKilled_ = review _ThreadKilled () -#endif --- | This 'Exception' is raised by default in the main thread of the program when +-- | This t'Exception' is raised by default in the main thread of the program when -- the user requests to terminate the program via the usual mechanism(s) -- (/e.g./ Control-C in the console). -- @@ -875,10 +817,9 @@ seta t = Left (pure t) {-# INLINE _UserInterrupt #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern UserInterrupt_ :: AsAsyncException s => s pattern UserInterrupt_ <- (has _UserInterrupt -> True) where UserInterrupt_ = review _UserInterrupt () -#endif ---------------------------------------------------------------------------- -- AsyncException @@ -895,7 +836,7 @@ -- @ __NonTermination :: Prism' t NonTermination - -- | There is no additional information carried in a 'NonTermination' 'Exception'. + -- | There is no additional information carried in a 'NonTermination' t'Exception'. -- -- @ -- '_NonTermination' :: 'Prism'' 'NonTermination' () @@ -916,13 +857,13 @@ __NonTermination = exception {-# INLINE __NonTermination #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern NonTermination__ :: AsNonTermination s => NonTermination -> s pattern NonTermination__ e <- (preview __NonTermination -> Just e) where NonTermination__ e = review __NonTermination e +pattern NonTermination_ :: AsNonTermination s => s pattern NonTermination_ <- (has _NonTermination -> True) where NonTermination_ = review _NonTermination () -#endif ---------------------------------------------------------------------------- -- NestedAtomically @@ -938,7 +879,7 @@ -- @ __NestedAtomically :: Prism' t NestedAtomically - -- | There is no additional information carried in a 'NestedAtomically' 'Exception'. + -- | There is no additional information carried in a 'NestedAtomically' t'Exception'. -- -- @ -- '_NestedAtomically' :: 'Prism'' 'NestedAtomically' () @@ -959,13 +900,13 @@ __NestedAtomically = exception {-# INLINE __NestedAtomically #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern NestedAtomically__ :: AsNestedAtomically s => NestedAtomically -> s pattern NestedAtomically__ e <- (preview __NestedAtomically -> Just e) where NestedAtomically__ e = review __NestedAtomically e +pattern NestedAtomically_ :: AsNestedAtomically s => s pattern NestedAtomically_ <- (has _NestedAtomically -> True) where NestedAtomically_ = review _NestedAtomically () -#endif ---------------------------------------------------------------------------- -- BlockedIndefinitelyOnMVar @@ -982,7 +923,7 @@ -- @ __BlockedIndefinitelyOnMVar :: Prism' t BlockedIndefinitelyOnMVar - -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'. + -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' t'Exception'. -- -- @ -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'BlockedIndefinitelyOnMVar' () @@ -1003,13 +944,13 @@ __BlockedIndefinitelyOnMVar = exception {-# INLINE __BlockedIndefinitelyOnMVar #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern BlockedIndefinitelyOnMVar__ :: AsBlockedIndefinitelyOnMVar s => BlockedIndefinitelyOnMVar -> s pattern BlockedIndefinitelyOnMVar__ e <- (preview __BlockedIndefinitelyOnMVar -> Just e) where BlockedIndefinitelyOnMVar__ e = review __BlockedIndefinitelyOnMVar e +pattern BlockedIndefinitelyOnMVar_ :: AsBlockedIndefinitelyOnMVar s => s pattern BlockedIndefinitelyOnMVar_ <- (has _BlockedIndefinitelyOnMVar -> True) where BlockedIndefinitelyOnMVar_ = review _BlockedIndefinitelyOnMVar () -#endif ---------------------------------------------------------------------------- -- BlockedIndefinitelyOnSTM @@ -1026,7 +967,7 @@ -- @ __BlockedIndefinitelyOnSTM :: Prism' t BlockedIndefinitelyOnSTM - -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'. + -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' t'Exception'. -- -- @ -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'BlockedIndefinitelyOnSTM' () @@ -1047,20 +988,20 @@ __BlockedIndefinitelyOnSTM = exception {-# INLINE __BlockedIndefinitelyOnSTM #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern BlockedIndefinitelyOnSTM__ :: AsBlockedIndefinitelyOnSTM s => BlockedIndefinitelyOnSTM -> s pattern BlockedIndefinitelyOnSTM__ e <- (preview __BlockedIndefinitelyOnSTM -> Just e) where BlockedIndefinitelyOnSTM__ e = review __BlockedIndefinitelyOnSTM e +pattern BlockedIndefinitelyOnSTM_ :: AsBlockedIndefinitelyOnSTM s => s pattern BlockedIndefinitelyOnSTM_ <- (has _BlockedIndefinitelyOnSTM -> True) where BlockedIndefinitelyOnSTM_ = review _BlockedIndefinitelyOnSTM () -#endif ---------------------------------------------------------------------------- -- Deadlock ---------------------------------------------------------------------------- -- | There are no runnable threads, so the program is deadlocked. The --- 'Deadlock' 'Exception' is raised in the main thread only. +-- 'Deadlock' t'Exception' is raised in the main thread only. class AsDeadlock t where -- | -- @ @@ -1069,7 +1010,7 @@ -- @ __Deadlock :: Prism' t Deadlock - -- | There is no information carried in a 'Deadlock' 'Exception'. + -- | There is no information carried in a 'Deadlock' t'Exception'. -- -- @ -- '_Deadlock' :: 'Prism'' 'Deadlock' () @@ -1090,13 +1031,13 @@ __Deadlock = exception {-# INLINE __Deadlock #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Deadlock__ :: AsDeadlock s => Deadlock -> s pattern Deadlock__ e <- (preview __Deadlock -> Just e) where Deadlock__ e = review __Deadlock e +pattern Deadlock_ :: AsDeadlock s => s pattern Deadlock_ <- (has _Deadlock -> True) where Deadlock_ = review _Deadlock () -#endif ---------------------------------------------------------------------------- -- NoMethodError @@ -1133,13 +1074,13 @@ __NoMethodError = exception {-# INLINE __NoMethodError #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern NoMethodError__ :: AsNoMethodError s => NoMethodError -> s pattern NoMethodError__ e <- (preview __NoMethodError -> Just e) where NoMethodError__ e = review __NoMethodError e +pattern NoMethodError_ :: AsNoMethodError s => String -> s pattern NoMethodError_ e <- (preview _NoMethodError -> Just e) where NoMethodError_ e = review _NoMethodError e -#endif ---------------------------------------------------------------------------- -- PatternMatchFail @@ -1175,13 +1116,13 @@ __PatternMatchFail = exception {-# INLINE __PatternMatchFail #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern PatternMatchFail__ :: AsPatternMatchFail s => PatternMatchFail -> s pattern PatternMatchFail__ e <- (preview __PatternMatchFail -> Just e) where PatternMatchFail__ e = review __PatternMatchFail e +pattern PatternMatchFail_ :: AsPatternMatchFail s => String -> s pattern PatternMatchFail_ e <- (preview _PatternMatchFail -> Just e) where PatternMatchFail_ e = review _PatternMatchFail e -#endif ---------------------------------------------------------------------------- -- RecConError @@ -1218,13 +1159,13 @@ __RecConError = exception {-# INLINE __RecConError #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern RecConError__ :: AsRecConError s => RecConError -> s pattern RecConError__ e <- (preview __RecConError -> Just e) where RecConError__ e = review __RecConError e +pattern RecConError_ :: AsRecConError s => String -> s pattern RecConError_ e <- (preview _RecConError -> Just e) where RecConError_ e = review _RecConError e -#endif ---------------------------------------------------------------------------- -- RecSelError @@ -1262,13 +1203,13 @@ __RecSelError = exception {-# INLINE __RecSelError #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern RecSelError__ :: AsRecSelError s => RecSelError -> s pattern RecSelError__ e <- (preview __RecSelError -> Just e) where RecSelError__ e = review __RecSelError e +pattern RecSelError_ :: AsRecSelError s => String -> s pattern RecSelError_ e <- (preview _RecSelError -> Just e) where RecSelError_ e = review _RecSelError e -#endif ---------------------------------------------------------------------------- -- RecUpdError @@ -1306,13 +1247,13 @@ __RecUpdError = exception {-# INLINE __RecUpdError #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern RecUpdError__ :: AsRecUpdError s => RecUpdError -> s pattern RecUpdError__ e <- (preview __RecUpdError -> Just e) where RecUpdError__ e = review __RecUpdError e +pattern RecUpdError_ :: AsRecUpdError s => String -> s pattern RecUpdError_ e <- (preview _RecUpdError -> Just e) where RecUpdError_ e = review _RecUpdError e -#endif ---------------------------------------------------------------------------- -- ErrorCall @@ -1353,15 +1294,14 @@ __ErrorCall = exception {-# INLINE __ErrorCall #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern ErrorCall__ :: AsErrorCall s => ErrorCall -> s pattern ErrorCall__ e <- (preview __ErrorCall -> Just e) where ErrorCall__ e = review __ErrorCall e +pattern ErrorCall_ :: AsErrorCall s => String -> s pattern ErrorCall_ e <- (preview _ErrorCall -> Just e) where ErrorCall_ e = review _ErrorCall e -#endif -#if MIN_VERSION_base(4,8,0) ---------------------------------------------------------------------------- -- AllocationLimitExceeded ---------------------------------------------------------------------------- @@ -1376,7 +1316,7 @@ __AllocationLimitExceeded :: Prism' t AllocationLimitExceeded -- | There is no additional information carried in an - -- 'AllocationLimitExceeded' 'Exception'. + -- 'AllocationLimitExceeded' t'Exception'. -- -- @ -- '_AllocationLimitExceeded' :: 'Prism'' 'AllocationLimitExceeded' () @@ -1397,14 +1337,14 @@ __AllocationLimitExceeded = exception {-# INLINE __AllocationLimitExceeded #-} +pattern AllocationLimitExceeded__ :: AsAllocationLimitExceeded s => AllocationLimitExceeded -> s pattern AllocationLimitExceeded__ e <- (preview __AllocationLimitExceeded -> Just e) where AllocationLimitExceeded__ e = review __AllocationLimitExceeded e +pattern AllocationLimitExceeded_ :: AsAllocationLimitExceeded s => s pattern AllocationLimitExceeded_ <- (has _AllocationLimitExceeded -> True) where AllocationLimitExceeded_ = review _AllocationLimitExceeded () -#endif -#if MIN_VERSION_base(4,9,0) ---------------------------------------------------------------------------- -- TypeError ---------------------------------------------------------------------------- @@ -1440,12 +1380,13 @@ __TypeError = exception {-# INLINE __TypeError #-} +pattern TypeError__ :: AsTypeError s => TypeError -> s pattern TypeError__ e <- (preview __TypeError -> Just e) where TypeError__ e = review __TypeError e +pattern TypeError_ :: AsTypeError s => String -> s pattern TypeError_ e <- (preview _TypeError -> Just e) where TypeError_ e = review _TypeError e -#endif #if MIN_VERSION_base(4,10,0) ---------------------------------------------------------------------------- @@ -1483,9 +1424,11 @@ __CompactionFailed = exception {-# INLINE __CompactionFailed #-} +pattern CompactionFailed__ :: AsCompactionFailed s => CompactionFailed -> s pattern CompactionFailed__ e <- (preview __CompactionFailed -> Just e) where CompactionFailed__ e = review __CompactionFailed e +pattern CompactionFailed_ :: AsCompactionFailed s => String -> s pattern CompactionFailed_ e <- (preview _CompactionFailed -> Just e) where CompactionFailed_ e = review _CompactionFailed e #endif @@ -1494,7 +1437,7 @@ -- HandlingException ------------------------------------------------------------------------------ --- | This 'Exception' is thrown by @lens@ when the user somehow manages to rethrow +-- | This t'Exception' is thrown by @lens@ when the user somehow manages to rethrow -- an internal 'HandlingException'. class AsHandlingException t where -- | @@ -1525,13 +1468,13 @@ __HandlingException = exception {-# INLINE __HandlingException #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern HandlingException__ :: AsHandlingException s => HandlingException -> s pattern HandlingException__ e <- (preview __HandlingException -> Just e) where HandlingException__ e = review __HandlingException e +pattern HandlingException_ :: AsHandlingException s => s pattern HandlingException_ <- (has _HandlingException -> True) where HandlingException_ = review _HandlingException () -#endif ------------------------------------------------------------------------------ -- Helper Functions @@ -1539,4 +1482,3 @@ trivial :: t -> Iso' t () trivial t = const () `iso` const t - diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -14,7 +14,7 @@ -- -- @ -- import Control.Lens --- +-- -- data FooBar a -- = Foo { _x :: ['Int'], _y :: a } -- | Bar { _x :: ['Int'] } @@ -25,7 +25,7 @@ -- -- @ -- x :: 'Lens'' (FooBar a) ['Int'] --- y :: 'Traversal' (FooBar a) (FooBar b) a b +-- y :: t'Traversal' (FooBar a) (FooBar b) a b -- @ -- -- You can then access the value of @_x@ with ('^.'), the value of @_y@ – @@ -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,32 +50,48 @@ 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 Data.Kind +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (isJust) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) +import qualified Data.Text as StrictT +import qualified Data.Text.Lazy as LazyT import Data.Tree -import Data.Vector as Vector hiding (indexed) -import Data.Vector.Primitive as Prim -import Data.Vector.Storable as Storable -import Data.Vector.Unboxed as Unboxed 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) +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif import Data.Word +import Foreign.Storable (Storable) -type family Index (s :: *) :: * +type family Index (s :: Type) :: Type type instance Index (e -> a) = e type instance Index IntSet = Int type instance Index (Set a) = a @@ -100,6 +116,9 @@ type instance Index (Prim.Vector a) = Int type instance Index (Storable.Vector a) = Int type instance Index (Unboxed.Vector a) = Int +#if MIN_VERSION_vector(0,13,2) +type instance Index (VectorStrict.Vector a) = Int +#endif type instance Index (Complex a) = Int type instance Index (Identity a) = () type instance Index (Maybe a) = () @@ -112,6 +131,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,22 +174,42 @@ {-# INLINE icontains #-} instance Contains IntSet where - contains k f s = f (IntSet.member k s) <&> \b -> - if b then IntSet.insert k s else IntSet.delete k s +#if MIN_VERSION_containers(0,6,3) + contains k f = IntSet.alterF f k +#else + -- This is a flipped copy of the implementation of `IntSet.alterF`. Unlike a + -- `Set`, we don't have to worry about expensive comparisons from descending + -- multiple times into an `IntSet`. We are careful to share the results of + -- insertion or deletion across multiple positions in the `Functor`. + contains k f s = fmap choose (f member_) + where + member_ = IntSet.member k s + + (inserted, deleted) + | member_ = (s, IntSet.delete k s) + | otherwise = (IntSet.insert k s, s) + + choose True = inserted + choose False = deleted +#endif {-# INLINE contains #-} instance Ord a => Contains (Set a) where +#if MIN_VERSION_containers(0,6,3) + contains k f = Set.alterF f k +#else contains k f s = f (Set.member k s) <&> \b -> if b then Set.insert k s else Set.delete k s +#endif {-# INLINE contains #-} instance (Eq a, Hashable a) => Contains (HashSet a) where - contains k f s = f (HashSet.member k s) <&> \b -> - if b then HashSet.insert k s else HashSet.delete k s + contains k f s = HashSet.fromMap <$> + HashMap.alterF (fmap guard . f . isJust) k (HashSet.toMap s) {-# INLINE contains #-} -- | This provides a common notion of a value at an index that is shared by both 'Ixed' and 'At'. -type family IxValue (m :: *) :: * +type family IxValue (m :: Type) :: Type -- | Provides a simple 'Traversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. @@ -190,7 +232,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 +266,8 @@ type instance IxValue (Maybe a) = a instance Ixed (Maybe a) where - ix () f (Just a) = Just <$> f a - ix () _ Nothing = pure Nothing + ix ~() f (Just a) = Just <$> f a + ix ~() _ Nothing = pure Nothing {-# INLINE ix #-} type instance IxValue [a] = a @@ -247,7 +289,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 +332,21 @@ type instance IxValue (Set k) = () instance Ord k => Ixed (Set k) where ix k f m = if Set.member k m - then f () <&> \() -> Set.insert k m + then f () $> m else pure m {-# INLINE ix #-} type instance IxValue IntSet = () instance Ixed IntSet where ix k f m = if IntSet.member k m - then f () <&> \() -> IntSet.insert k m + then f () $> m else pure m {-# INLINE ix #-} type instance IxValue (HashSet k) = () instance (Eq k, Hashable k) => Ixed (HashSet k) where ix k f m = if HashSet.member k m - then f () <&> \() -> HashSet.insert k m + then f () $> m else pure m {-# INLINE ix #-} @@ -360,37 +402,54 @@ | otherwise = pure v {-# INLINE ix #-} +#if MIN_VERSION_vector(0,13,2) +type instance IxValue (VectorStrict.Vector a) = a +instance Ixed (VectorStrict.Vector a) where + ix i f v + | 0 <= i && i < VectorStrict.length v = f (v VectorStrict.! i) <&> \a -> v VectorStrict.// [(i, a)] + | otherwise = pure v + {-# INLINE ix #-} +#endif + type instance IxValue StrictT.Text = Char instance Ixed StrictT.Text where - ix e f s = case StrictT.splitAt e s of - (l, mr) -> case StrictT.uncons mr of - Nothing -> pure s - Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs] + ix e f s + | e < 0 = pure s + | otherwise = case StrictT.splitAt e s of + (l, mr) -> case StrictT.uncons mr of + Nothing -> pure s + Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyT.Text = Char instance Ixed LazyT.Text where - ix e f s = case LazyT.splitAt e s of - (l, mr) -> case LazyT.uncons mr of - Nothing -> pure s - Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs) + ix e f s + | e < 0 = pure s + | otherwise = case LazyT.splitAt e s of + (l, mr) -> case LazyT.uncons mr of + Nothing -> pure s + Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs) {-# INLINE ix #-} type instance IxValue StrictB.ByteString = Word8 instance Ixed StrictB.ByteString where - ix e f s = case StrictB.splitAt e s of - (l, mr) -> case StrictB.uncons mr of - Nothing -> pure s - Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs] + ix e f s + | e < 0 = pure s + | otherwise = case StrictB.splitAt e s of + (l, mr) -> case StrictB.uncons mr of + Nothing -> pure s + Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyB.ByteString = Word8 instance Ixed LazyB.ByteString where -- TODO: we could be lazier, returning each chunk as it is passed - ix e f s = case LazyB.splitAt e s of - (l, mr) -> case LazyB.uncons mr of - Nothing -> pure s - Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs) + ix e f s + | e < 0 = pure s + | otherwise = case LazyB.splitAt e s of + (l, mr) -> case LazyB.uncons mr of + Nothing -> pure s + Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs) {-# INLINE ix #-} @@ -441,7 +500,7 @@ {-# INLINE iat #-} instance At (Maybe a) where - at () f = f + at ~() f = f {-# INLINE at #-} instance At (IntMap a) where @@ -467,70 +526,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 @@ , (.@=) , (.@~) , (^#) - , ( #~ ) - , ( #%~ ) - , ( #%%~ ) - , ( #= ) - , ( #%= ) + , (#~) + , (#%~) + , (#%%~) + , (#=) + , (#%=) , (<#%~) , (<#%=) - , ( #%%= ) + , (#%%=) , (<#~) , (<#=) , (...) - , ( # ) + , (#) , (%~) , (.~) , (?~) @@ -139,10 +139,20 @@ , (~) , (<>=) + , (<>:~) + , (<>:=) + , (<<>:~) + , (<<>:=) + , (<|~) + , (<|=) + , (<<|~) + , (<<|=) + , (|>~) + , (|>=) + , (<|>~) + , (<|>=) , (%@~) , (%@=) -#if __GLASGOW_HASKELL__ >= 710 , (:>) , (:<) -#endif ) 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 @@ -4,12 +4,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | @@ -29,33 +27,33 @@ , cons , uncons , _head, _tail -#if __GLASGOW_HASKELL__ >= 710 + , (<|~), (<|=), (<<|~), (<<|=), (<<<|~), (<<<|=) , pattern (:<) -#endif -- * Snoc , Snoc(..) , (|>) , snoc , unsnoc , _init, _last -#if __GLASGOW_HASKELL__ >= 710 + , (|>~), (|>=), (<|>~), (<|>=), (<<|>~), (<<|>=) , pattern (:>) -#endif ) where import Control.Lens.Equality (simply) import Control.Lens.Fold +import Control.Lens.Lens import Control.Lens.Prism import Control.Lens.Review +import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Type -import 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) @@ -66,17 +64,20 @@ import qualified Data.Vector.Primitive as Prim import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif import Data.Word import Control.Applicative (ZipList(..)) +import Control.Monad.State.Class as State 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 @@ -84,20 +85,20 @@ infixr 5 <|, `cons` infixl 5 |>, `snoc` - -#if __GLASGOW_HASKELL__ >= 710 +infixr 4 <|~, |>~, <<|~, <|>~, <<<|~, <<|>~ +infix 4 <|=, |>=, <<|=, <|>=, <<<|=, <<|>= +pattern (:<) :: Cons b b a a => a -> b -> b pattern (:<) a s <- (preview _Cons -> Just (a,s)) where (:<) a s = _Cons # (a,s) infixr 5 :< infixl 5 :> +pattern (:>) :: Snoc a a b b => a -> b -> a pattern (:>) s a <- (preview _Snoc -> Just (s,a)) where (:>) a s = _Snoc # (a,s) -#endif - ------------------------------------------------------------------------------ -- Cons ------------------------------------------------------------------------------ @@ -125,7 +126,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 @@ -182,6 +183,15 @@ else Right (Unbox.unsafeHead v, Unbox.unsafeTail v) {-# INLINE _Cons #-} +#if MIN_VERSION_vector(0,13,2) +instance Cons (VectorStrict.Vector a) (VectorStrict.Vector b) a b where + _Cons = prism (uncurry VectorStrict.cons) $ \v -> + if VectorStrict.null v + then Left VectorStrict.empty + else Right (VectorStrict.unsafeHead v, VectorStrict.unsafeTail v) + {-# INLINE _Cons #-} +#endif + -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'. @@ -332,6 +342,49 @@ _tail = _Cons._2 {-# INLINE _tail #-} +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('<|')@. +-- +-- >>> (["world"], ["lens"]) & _1 <|~ "hello" +-- (["hello","world"],["lens"]) +(<|~) :: Cons b b a a => ASetter s t b b -> a -> s -> t +l <|~ n = over l (n <|) +{-# INLINE (<|~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('<|')@. +(<|=) :: (MonadState s m, Cons b b a a) => ASetter s s b b -> a -> m () +l <|= a = State.modify (l <|~ a) +{-# INLINE (<|=) #-} + +-- | ('<|') a value onto the target of a 'Lens' and return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible. +(<<|~) :: Cons b b a a => LensLike ((,) b) s t b b -> a -> s -> (b, t) +l <<|~ m = l <%~ (m <|) +{-# INLINE (<<|~) #-} + +-- | ('<|') a value onto the target of a 'Lens' and return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible. +(<<<|~) :: Cons b b a a => LensLike' ((,) b) s b -> a -> s -> (b, s) +l <<<|~ m = l <<%~ (m <|) +{-# INLINE (<<<|~) #-} + +-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible. +(<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b +l <<|= r = l <%= (r <|) +{-# INLINE (<<|=) #-} + +-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible. +(<<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b +l <<<|= r = l <<%= (r <|) +{-# INLINE (<<<|=) #-} + ------------------------------------------------------------------------------ -- Snoc ------------------------------------------------------------------------------ @@ -359,7 +412,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 @@ -501,7 +554,7 @@ _last = _Snoc._2 {-# INLINE _last #-} --- | 'snoc' an element onto the end of a container. +-- | 'snoc' an element onto a container. -- -- This is an infix alias for 'snoc'. -- @@ -517,7 +570,7 @@ (|>) = curry (simply review _Snoc) {-# INLINE (|>) #-} --- | 'snoc' an element onto the end of a container. +-- | 'snoc' an element onto a container. -- -- >>> snoc (Seq.fromList []) a -- fromList [a] @@ -545,5 +598,48 @@ -- >>> unsnoc (Seq.fromList []) -- Nothing unsnoc :: Snoc s s a a => s -> Maybe (s, a) -unsnoc s = simply preview _Snoc s +unsnoc = simply preview _Snoc {-# INLINE unsnoc #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('|>')@. +-- +-- >>> (["world"], ["lens"]) & _1 |>~ "hello" +-- (["world","hello"],["lens"]) +(|>~) :: Snoc b b a a => ASetter s t b b -> a -> s -> t +l |>~ n = over l (|> n) +{-# INLINE (|>~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('|>')@. +(|>=) :: (MonadState s m, Snoc b b a a) => ASetter s s b b -> a -> m () +l |>= a = State.modify (l |>~ a) +{-# INLINE (|>=) #-} + +-- | ('|>') a value onto the target of a 'Lens' and return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible. +(<|>~) :: Snoc b b p p => LensLike ((,) b) s t b b -> p -> s -> (b, t) +l <|>~ m = l <%~ (|> m) +{-# INLINE (<|>~) #-} + +-- | ('|>') a value onto the target of a 'Lens' and return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible. +(<<|>~) :: Snoc b b p p => LensLike' ((,) b) s b -> p -> s -> (b, s) +l <<|>~ m = l <<%~ (|> m) +{-# INLINE (<<|>~) #-} + +-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible. +(<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b +l <|>= r = l <%= (|> r) +{-# INLINE (<|>=) #-} + +-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and +-- return the /old/ result. +-- +-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible. +(<<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b +l <<|>= r = l <<%= (|> r) +{-# INLINE (<<|>=) #-} diff --git a/src/Control/Lens/Each.hs b/src/Control/Lens/Each.hs --- a/src/Control/Lens/Each.hs +++ b/src/Control/Lens/Each.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} @@ -35,16 +36,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 @@ -53,8 +54,13 @@ import qualified Data.Vector.Storable as Storable import Data.Vector.Storable (Storable) import qualified Data.Vector.Unboxed as Unboxed +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif import Data.Vector.Unboxed (Unbox) import Data.Word +import qualified Data.Strict as S +import Data.These (These (..)) -- $setup -- >>> :set -XNoOverloadedStrings @@ -192,6 +198,13 @@ each = vectorTraverse {-# INLINE each #-} +#if MIN_VERSION_vector(0,13,2) +-- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@ +instance Each (VectorStrict.Vector a) (VectorStrict.Vector b) a b where + each = vectorTraverse + {-# INLINE each #-} +#endif + -- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@ instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where each = text @@ -221,3 +234,37 @@ instance (Ix i, IArray UArray a, IArray UArray b, i ~ j) => Each (UArray i a) (UArray j b) a b where each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr) {-# INLINE each #-} + +------------------------------------------------------------------------------- +-- strict +------------------------------------------------------------------------------- + +-- | @since 4.20 +instance (a ~ a', b ~ b') => Each (S.Either a a') (S.Either b b') a b where + each f (S.Left x) = S.Left <$> f x + each f (S.Right x) = S.Right <$> f x + {-# INLINE each #-} + +-- | @since 4.20 +instance (a~a', b~b') => Each (S.Pair a a') (S.Pair b b') a b where + each f (a S.:!: b) = (S.:!:) <$> f a <*> f b + {-# INLINE each #-} + +-- | @since 4.20 +instance Each (S.Maybe a) (S.Maybe b) a b + +-- | @since 4.20 +instance (a ~ a', b ~ b') => Each (S.These a a') (S.These b b') a b where + each f (S.This a) = S.This <$> f a + each f (S.That b) = S.That <$> f b + each f (S.These a b) = S.These <$> f a <*> f b + +------------------------------------------------------------------------------- +-- these +------------------------------------------------------------------------------- + +-- | @since 4.20 +instance (a ~ a', b ~ b') => Each (These a a') (These b b') a b where + each f (This a) = This <$> f a + each f (That b) = That <$> f b + each f (These a b) = These <$> f a <*> f b diff --git a/src/Control/Lens/Empty.hs b/src/Control/Lens/Empty.hs --- a/src/Control/Lens/Empty.hs +++ b/src/Control/Lens/Empty.hs @@ -1,15 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -#endif - ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Empty @@ -23,41 +20,52 @@ module Control.Lens.Empty ( AsEmpty(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern Empty -#endif ) where import Prelude () import Control.Lens.Iso -#if __GLASGOW_HASKELL__ >= 710 import Control.Lens.Fold -#endif 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 qualified Data.Vector.Primitive as Prim +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif +import Foreign.Storable (Storable) #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) import GHC.Event #endif +-- $setup +-- >>> import Control.Lens + class AsEmpty a where -- | -- @@ -68,10 +76,9 @@ _Empty = only mempty {-# INLINE _Empty #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Empty :: AsEmpty s => s pattern Empty <- (has _Empty -> True) where Empty = review _Empty () -#endif {- Default Monoid instances -} instance AsEmpty Ordering @@ -158,9 +165,19 @@ _Empty = nearly Unboxed.empty Unboxed.null {-# INLINE _Empty #-} +instance Prim.Prim a => AsEmpty (Prim.Vector a) where + _Empty = nearly Prim.empty Prim.null + {-# INLINE _Empty #-} + instance Storable a => AsEmpty (Storable.Vector a) where _Empty = nearly Storable.empty Storable.null {-# INLINE _Empty #-} + +#if MIN_VERSION_vector(0,13,2) +instance AsEmpty (VectorStrict.Vector a) where + _Empty = nearly VectorStrict.empty VectorStrict.null + {-# INLINE _Empty #-} +#endif instance AsEmpty (Seq.Seq a) where _Empty = nearly Seq.empty Seq.null 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,10 +3,11 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE Trustworthy #-} + +#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 800 +#else {-# LANGUAGE TypeInType #-} #endif @@ -49,16 +50,9 @@ import Control.Lens.Type import Data.Proxy (Proxy) import Data.Type.Equality ((:~:)(..)) -#if __GLASGOW_HASKELL__ >= 800 import GHC.Exts (TYPE) 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 @@ -88,24 +78,14 @@ {-# INLINE runEq #-} -- | Substituting types with 'Equality'. -#if __GLASGOW_HASKELL__ >= 800 substEq :: forall s t a b rep (r :: TYPE rep). AnEquality s t a b -> ((s ~ a, t ~ b) => r) -> r -#else -substEq :: AnEquality s t a b -> ((s ~ a, t ~ b) => r) -> r -#endif substEq l = case runEq l of Identical -> \r -> r {-# INLINE substEq #-} -- | 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 -#endif mapEq l r = substEq l r {-# INLINE mapEq #-} @@ -116,12 +96,8 @@ -- | This is an adverb that can be used to modify many other 'Lens' combinators to make them require -- simple lenses, simple traversals, simple prisms or simple isos as input. -#if __GLASGOW_HASKELL__ >= 800 simply :: forall p f s a rep (r :: TYPE rep). (Optic' p f s a -> r) -> Optic' p f s a -> r -#else -simply :: (Optic' p f s a -> r) -> Optic' p f s a -> r -#endif simply = id {-# INLINE simply #-} @@ -173,19 +149,12 @@ -- -- @fromLeibniz' :: (forall f. f s -> f a) -> Equality' s a@ fromLeibniz' :: (s :~: s -> s :~: a) -> Equality' s a --- Note: even though its type signature mentions (:~:), this function works just --- fine in base versions before 4.7.0; it just requires a polymorphic argument! fromLeibniz' f = case f Refl of Refl -> id {-# INLINE fromLeibniz' #-} -- | A version of 'substEq' that provides explicit, rather than implicit, -- equality evidence. -#if __GLASGOW_HASKELL__ >= 800 withEquality :: forall s t a b rep (r :: TYPE rep). AnEquality s t a b -> (s :~: a -> b :~: t -> r) -> r -#else -withEquality :: forall s t a b r. - AnEquality s t a b -> (s :~: a -> b :~: t -> r) -> r -#endif withEquality an = substEq an (\f -> f Refl Refl) {-# INLINE withEquality #-} diff --git a/src/Control/Lens/Extras.hs b/src/Control/Lens/Extras.hs --- a/src/Control/Lens/Extras.hs +++ b/src/Control/Lens/Extras.hs @@ -22,7 +22,7 @@ -- >>> import Control.Lens -- >>> import Numeric.Lens (hex) --- | Check to see if this 'Prism' matches. +-- | Check to see if this t'Prism' matches. -- -- >>> is _Left (Right 12) -- False diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -7,7 +7,7 @@ {-# LANGUAGE Trustworthy #-} #include "lens-common.h" -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold @@ -74,6 +74,7 @@ , foldMapOf, foldOf , foldrOf, foldlOf , toListOf, toNonEmptyOf + , altOf , anyOf, allOf, noneOf , andOf, orOf , productOf, sumOf @@ -162,10 +163,8 @@ import Data.Int (Int64) import Data.List (intercalate) import Data.Maybe (fromMaybe) -import Data.Monoid (First (..), All (..), Any (..)) -#if MIN_VERSION_reflection(2,1,0) +import Data.Monoid (First (..), All (..), Alt (..), Any (..)) import Data.Reflection -#endif import qualified Data.Semigroup as Semi @@ -175,6 +174,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 +187,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 ^.., ^?, ^?!, ^@.., ^@?, ^@?! -------------------------- @@ -204,8 +197,8 @@ -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -- --- >>> [1,2,3,4]^..folding tail --- [2,3,4] +-- >>> [1,2,3,4]^..folding reverse +-- [4,3,2,1] folding :: Foldable f => (s -> f a) -> Fold s a folding sfa agb = phantom . traverse_ agb . sfa {-# INLINE folding #-} @@ -306,7 +299,7 @@ -- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1)) -- [10,9,8,7,6,5,4,3,2,1] unfolded :: (b -> Maybe (a, b)) -> Fold b a -unfolded f g b0 = go b0 where +unfolded f g = go where go b = case f b of Just (a, b') -> g a *> go b' Nothing -> noEffect @@ -322,7 +315,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 #-} @@ -540,7 +533,7 @@ -- 'foldMapOf' :: 'Getting' r s a -> (a -> r) -> s -> r -- @ foldMapOf :: Getting r s a -> (a -> r) -> s -> r -foldMapOf l f = getConst #. l (Const #. f) +foldMapOf = coerce {-# INLINE foldMapOf #-} -- | Combine the elements of a structure viewed through a 'Lens', 'Getter', @@ -646,11 +639,37 @@ -- 'toNonEmptyOf' :: 'Lens'' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Iso'' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Traversal1'' s a -> s -> NonEmpty a --- 'toNonEmptyOf' :: 'Prism'' s a -> s -> NonEmpty a -- @ toNonEmptyOf :: Getting (NonEmptyDList a) s a -> s -> NonEmpty a toNonEmptyOf l = flip getNonEmptyDList [] . foldMapOf l (NonEmptyDList #. (:|)) +-- | Calls 'pure' on the target of a 'Lens', 'Getter', or 'Iso'. +-- +-- Calls 'pure' on the targets of a 'Traversal', 'Fold', or 'Prism', and +-- combines them with '<|>' (or `empty` if none). Intuitively, it collects +-- targets into an 'Alternative' until the container fills up or it runs out of +-- targets, whichever comes first. +-- +-- Generalizes 'toListOf' and '(^?)'. +-- +-- >>> altOf both ("hello", "world") :: [String] +-- ["hello","world"] +-- >>> altOf both ("hello", "world") :: Maybe String +-- Just "hello" +-- +-- @ +-- 'altOf' :: Applicative f => 'Lens'' s a -> s -> f a +-- 'altOf' :: Applicative f => 'Getter' s a -> s -> f a +-- 'altOf' :: Applicative f => 'Iso'' s a -> s -> f a +-- +-- 'altOf' :: Alternative f => 'Traversal'' s a -> s -> f a +-- 'altOf' :: Alternative f => 'Fold' s a -> s -> f a +-- 'altOf' :: Alternative f => 'Prism'' s a -> s -> f a +-- @ +altOf :: Applicative f => Getting (Alt f a) s a -> s -> f a +altOf l = getAlt #. views l (Alt #. pure) +{-# INLINE altOf #-} + -- | A convenient infix (flipped) version of 'toListOf'. -- -- >>> [[1,2],[3]]^..id @@ -1177,7 +1196,7 @@ -- 'concatMapOf' :: 'Traversal'' s a -> (a -> [r]) -> s -> [r] -- @ concatMapOf :: Getting [r] s a -> (a -> [r]) -> s -> [r] -concatMapOf l ces = getConst #. l (Const #. ces) +concatMapOf = coerce {-# INLINE concatMapOf #-} -- | Concatenate all of the lists targeted by a 'Fold' into a longer list. @@ -1242,7 +1261,7 @@ -- way to extract the optional value. -- -- Note: if you get stack overflows due to this, you may want to use 'firstOf' instead, which can deal --- more gracefully with heavily left-biased trees. This is because '^?' works by using the +-- more gracefully with heavily left-biased trees. This is because '^?' works by using the -- 'Data.Monoid.First' monoid, which can occasionally cause space leaks. -- -- >>> Left 4 ^?_Left @@ -1257,7 +1276,7 @@ -- >>> "world" ^? ix 20 -- Nothing -- --- This operator works as an infix version of 'preview'. +-- This operator works as an infix version of 'preview'. -- -- @ -- ('^?') ≡ 'flip' 'preview' @@ -1265,7 +1284,7 @@ -- -- It may be helpful to think of '^?' as having one of the following -- more specialized types: --- +-- -- @ -- ('^?') :: s -> 'Getter' s a -> 'Maybe' a -- ('^?') :: s -> 'Fold' s a -> 'Maybe' a @@ -1735,8 +1754,9 @@ -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of :: HasCallStack => Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a -foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") - (foldrOf l mf Nothing xs) where +-- See: NOTE: [Inlining and arity] +foldr1Of l f = fromMaybe (error "foldr1Of: empty structure") + . foldrOf l mf Nothing where mf x my = Just $ case my of Nothing -> x Just y -> f x y @@ -1761,7 +1781,8 @@ -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of :: HasCallStack => Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a -foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where +-- See: NOTE: [Inlining and arity] +foldl1Of l f = fromMaybe (error "foldl1Of: empty structure") . foldlOf l mf Nothing where mf mx y = Just $ case mx of Nothing -> y Just x -> f x y @@ -1781,7 +1802,8 @@ -- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r -foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0 +-- See: NOTE: [Inlining and arity] +foldrOf' l f z0 = \xs -> foldlOf l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldrOf' #-} @@ -1799,7 +1821,8 @@ -- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r -foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0 +-- See: NOTE: [Inlining and arity] +foldlOf' l f z0 = \xs -> foldrOf l f' (Endo id) xs `appEndo` z0 where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} @@ -1819,7 +1842,8 @@ -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of' :: HasCallStack => Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a -foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where +-- See: NOTE: [Inlining and arity] +foldr1Of' l f = fromMaybe (error "foldr1Of': empty structure") . foldrOf' l mf Nothing where mf x Nothing = Just $! x mf x (Just y) = Just $! f x y {-# INLINE foldr1Of' #-} @@ -1840,7 +1864,8 @@ -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of' :: HasCallStack => Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a -foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where +-- See: NOTE: [Inlining and arity] +foldl1Of' l f = fromMaybe (error "foldl1Of': empty structure") . foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! f x y {-# INLINE foldl1Of' #-} @@ -1862,7 +1887,8 @@ foldrMOf :: Monad m => Getting (Dual (Endo (r -> m r))) s a -> (a -> r -> m r) -> r -> s -> m r -foldrMOf l f z0 xs = foldlOf l f' return xs z0 +-- See: NOTE: [Inlining and arity] +foldrMOf l f z0 = \xs -> foldlOf l f' return xs z0 where f' k x z = f x z >>= k {-# INLINE foldrMOf #-} @@ -1883,10 +1909,26 @@ foldlMOf :: Monad m => Getting (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r -foldlMOf l f z0 xs = foldrOf l f' return xs z0 +-- See: NOTE: [Inlining and arity] +foldlMOf l f z0 = \xs -> foldrOf l f' return xs z0 where f' x k z = f z x >>= k {-# INLINE foldlMOf #-} +-- NOTE: [Inlining and arity] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- GHC uses the following inlining heuristic: a function body is inlined if +-- all its arguments on the LHS are applied. So the following two definitions +-- are not equivalent from the inliner's PoV: +-- +-- > foldlOf' l f z0 xs = ... +-- > foldlOf' l f z0 = \xs -> ... +-- +-- GHC will be less eager to inline the first one and this results in +-- worse code. For example, a simple list summation using `sumOf` will be 8x slower +-- with the first version. + + -- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries. -- -- >>> has (element 0) [] @@ -1974,11 +2016,11 @@ -- @ -- 'preview' = 'view' '.' 'pre' -- @ --- -- --- Unlike '^?', this function uses a +-- +-- Unlike '^?', this function uses a -- 'Control.Monad.Reader.MonadReader' to read the value to be focused in on. --- This allows one to pass the value as the last argument by using the +-- This allows one to pass the value as the last argument by using the -- 'Control.Monad.Reader.MonadReader' instance for @(->) s@ -- However, it may also be used as part of some deeply nested transformer stack. -- @@ -1990,7 +2032,7 @@ -- -- It may be helpful to think of 'preview' as having one of the following -- more specialized types: --- +-- -- @ -- 'preview' :: 'Getter' s a -> s -> 'Maybe' a -- 'preview' :: 'Fold' s a -> s -> 'Maybe' a @@ -2006,7 +2048,7 @@ -- 'preview' :: 'MonadReader' s m => 'Lens'' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Iso'' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Traversal'' s a -> m ('Maybe' a) --- +-- -- @ preview :: MonadReader s m => Getting (First a) s a -> m (Maybe a) preview l = asks (getFirst #. foldMapOf l (First #. Just)) @@ -2218,7 +2260,7 @@ -- @ -- ifoldMapOf :: IndexedGetting i m s a -> (i -> a -> m) -> s -> m -ifoldMapOf l f = getConst #. l (Const #. Indexed f) +ifoldMapOf = coerce {-# INLINE ifoldMapOf #-} -- | Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with @@ -2275,7 +2317,7 @@ -- 'ianyOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ ianyOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool -ianyOf l f = getAny #. getConst #. l (Const #. Any #. Indexed f) +ianyOf = coerce {-# INLINE ianyOf #-} -- | Return whether or not all elements viewed through an 'IndexedFold' or 'IndexedTraversal' @@ -2294,7 +2336,7 @@ -- 'iallOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ iallOf :: IndexedGetting i All s a -> (i -> a -> Bool) -> s -> Bool -iallOf l f = getAll #. getConst #. l (Const #. All #. Indexed f) +iallOf = coerce {-# INLINE iallOf #-} -- | Return whether or not none of the elements viewed through an 'IndexedFold' or 'IndexedTraversal' 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,17 +4,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE NoPolyKinds #-} -{-# LANGUAGE NoDataKinds #-} -#endif - --- Disable the warnings generated by 'to', 'ito', 'like', 'ilike'. +-- Disable the warnings generated by 'Control.Lens.Getter.to', 'ito', 'like', 'ilike'. -- These functions are intended to produce 'Getters'. Without this constraint -- users would get warnings when annotating types at uses of these functions. -#if __GLASGOW_HASKELL__ >= 711 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif +{-# OPTIONS_GHC -Wno-redundant-constraints #-} ------------------------------------------------------------------------------- -- | @@ -98,7 +91,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 @@ -113,11 +108,11 @@ -- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function. -- -- @ --- 'to' f '.' 'to' g ≡ 'to' (g '.' f) +-- 'Control.Lens.Getter.to' f '.' 'Control.Lens.Getter.to' g ≡ 'Control.Lens.Getter.to' (g '.' f) -- @ -- -- @ --- a '^.' 'to' f ≡ f a +-- a '^.' 'Control.Lens.Getter.to' f ≡ f a -- @ -- -- >>> a ^.to f @@ -133,7 +128,7 @@ -- 5 -- -- @ --- 'to' :: (s -> a) -> 'IndexPreservingGetter' s a +-- 'Control.Lens.Getter.to' :: (s -> a) -> 'IndexPreservingGetter' s a -- @ to :: (Profunctor p, Contravariant f) => (s -> a) -> Optic' p f s a to k = dimap k (contramap k) @@ -153,7 +148,7 @@ -- @ -- 'like' a '.' 'like' b ≡ 'like' b -- a '^.' 'like' b ≡ b --- a '^.' 'like' b ≡ a '^.' 'to' ('const' b) +-- a '^.' 'like' b ≡ a '^.' 'Control.Lens.Getter.to' ('const' b) -- @ -- -- This can be useful as a second case 'failing' a 'Fold' @@ -210,7 +205,7 @@ -- at a monoidal value. -- -- @ --- 'view' '.' 'to' ≡ 'id' +-- 'view' '.' 'Control.Lens.Getter.to' ≡ 'id' -- @ -- -- >>> view (to f) a @@ -255,7 +250,7 @@ -- 'Control.Lens.Traversal.Traversal'. -- -- @ --- 'views' l f ≡ 'view' (l '.' 'to' f) +-- 'views' l f ≡ 'view' (l '.' 'Control.Lens.Getter.to' f) -- @ -- -- >>> views (to f) g a @@ -289,7 +284,7 @@ -- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r -- @ views :: MonadReader s m => LensLike' (Const r) s a -> (a -> r) -> m r -views l f = Reader.asks (getConst #. l (Const #. f)) +views l f = Reader.asks (coerce l f) {-# INLINE views #-} -- | View the value pointed to by a 'Getter' or 'Lens' or the @@ -463,7 +458,7 @@ -- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf' -- @ iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r -iviews l f = asks (getConst #. l (Const #. Indexed f)) +iviews l f = asks (coerce l f) {-# INLINE iviews #-} -- | Use the index and value of an 'IndexedGetter' into the current state as a pair. @@ -478,7 +473,7 @@ -- -- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r -iuses l f = gets (getConst #. l (Const #. Indexed f)) +iuses l f = gets (coerce l f) {-# INLINE iuses #-} -- | View the index and value of an 'IndexedGetter' or 'IndexedLens'. 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 @@ -1,14 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif -#if __GLASGOW_HASKELL__ >= 711 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif +{-# OPTIONS_GHC -Wno-redundant-constraints #-} ----------------------------------------------------------------------------- -- | @@ -38,6 +35,7 @@ import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Data.Functor.Apply +import Data.Kind import Data.Profunctor.Rep ------------------------------------------------------------------------------ @@ -147,10 +145,8 @@ -- -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! -newtype BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } -#if __GLASGOW_HASKELL__ >= 707 +newtype BazaarT p (g :: Type -> Type) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t } type role BazaarT representational nominal nominal nominal nominal -#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. -- @@ -230,8 +226,10 @@ instance Contravariant g => Monoid (BazaarT p g a b t) where mempty = BazaarT $ \_ -> pure (error "mempty: BazaarT") {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) BazaarT a `mappend` BazaarT b = BazaarT $ \f -> a f <* b f {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ @@ -325,10 +323,8 @@ -- -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! -newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t } -#if __GLASGOW_HASKELL__ >= 707 +newtype BazaarT1 p (g :: Type -> Type) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t } type role BazaarT1 representational nominal nominal nominal nominal -#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. -- 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 () @@ -49,14 +47,7 @@ import Data.Word (Word8) import Foreign.Ptr import Foreign.Storable -#if MIN_VERSION_base(4,8,0) import Foreign.ForeignPtr -#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 +119,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 +150,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 +185,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 +197,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 +210,9 @@ create l f = do fp <- mallocPlainForeignPtrBytes l withForeignPtr fp $ \p -> f p +#if MIN_VERSION_bytestring(0,11,0) + return $! BI.BS fp l +#else return $! BI.PS fp 0 l +#endif {-# INLINE create #-} diff --git a/src/Control/Lens/Internal/Coerce.hs b/src/Control/Lens/Internal/Coerce.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/Coerce.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# 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 --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- 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. ------------------------------------------------------------------------------ -module Control.Lens.Internal.Coerce - ( coerce - , coerce' - , (#..) - ) where - -import Data.Profunctor.Unsafe - -#ifdef USE_COERCE - -import Data.Coerce - -coerce' :: forall a b. Coercible a b => b -> a -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 #-} -{-# INLINE coerce' #-} - -(#..) :: Profunctor p => (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,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif ----------------------------------------------------------------------------- -- | @@ -36,6 +34,7 @@ import Control.Comonad.Store.Class import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude +import Data.Kind import Data.Profunctor.Rep import Prelude hiding ((.),id) @@ -63,9 +62,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 @@ -283,13 +281,11 @@ -- This is used internally to permit a number of combinators to gracefully -- degrade when applied to a 'Control.Lens.Fold.Fold' or -- 'Control.Lens.Getter.Getter'. -newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } +newtype PretextT p (g :: Type -> Type) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } -#if __GLASGOW_HASKELL__ >= 707 -- really we want PretextT p g a b t to permit the last 3 arguments to be representational iff p and f accept representational arguments -- but that isn't currently an option in GHC type role PretextT representational nominal nominal nominal nominal -#endif -- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@ type PretextT' p g a = PretextT p g a a 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 @@ -170,10 +173,12 @@ instance Monoid (Deque a) where mempty = BD 0 [] 0 [] {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend xs ys | size xs < size ys = foldr cons ys xs | otherwise = foldl snoc xs ys {-# INLINE mappend #-} +#endif -- | Check that a 'Deque' satisfies the balance invariants and rebalance if not. check :: Int -> [a] -> Int -> [a] -> Deque a @@ -188,7 +193,9 @@ if lf + lr == 0 then Left empty else Right $ case f of - [] -> (head r, empty) + [] -> case r of + y:_ -> (y, empty) + [] -> error "Control.Lens.Internal.Deque._Cons: Internal check failed" (x:xs) -> (x, check (lf - 1) xs lr r) {-# INLINE _Cons #-} @@ -197,6 +204,8 @@ if lf + lr == 0 then Left empty else Right $ case r of - [] -> (empty, head f) + [] -> case f of + y:_ -> (empty, y) + [] -> error "Control.Lens.Internal.Deque._Snoc: Internal check failed" (x:xs) -> (check lf f (lr - 1) xs, x) {-# INLINE _Snoc #-} diff --git a/src/Control/Lens/Internal/Doctest.hs b/src/Control/Lens/Internal/Doctest.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/Doctest.hs @@ -0,0 +1,43 @@ +-- | This module exists for the sole purpose of redefining the 'head' and 'tail' +-- functions (which are normally provided by the 'Prelude') so that they can be +-- used in the doctests of 'Data.Data.Lens'. +-- +-- The 'head' and 'tail' functions are partial, and as of GHC 9.8, there is a +-- @-Wx-partial@ warning (implied by @-Wall@) that triggers any time you use +-- either of these functions. This is a fairly reasonable default in most +-- settings, but there are a handful of doctests in 'Data.Data.Lens' that do in +-- fact rely on 'head' and 'tail' being partial functions. These doctests +-- demonstrate that various functions in 'Data.Data.Lens' can recover from +-- exceptions that are thrown due to partiality (see, for instance, the @upon@ +-- function). +-- +-- One possible workaround would be to disable @-Wx-partial@. We don't want to +-- disable the warning for /all/ code in @lens@, however—we only want to +-- disable it for a particular group of doctests. It is rather tricky to achieve +-- this level of granularity, unfortunately. This is because tools like +-- @cabal-docspec@ rely on GHCi to work, and the statefulness of GHCi's @:set@ +-- command means that disabling @-Wx-partial@ might leak into other modules' +-- doctests, which we don't want. +-- +-- Instead, we opt to redefine our own versions of 'head' and 'tail' here, which +-- do not trigger any @-Wx-partial@ warnings, and use them in the +-- 'Data.Data.Lens' doctests. This has no impact on anyone reading the doctests, +-- as these functions will look indistinguishable from the 'head' and 'tail' +-- functions in the 'Prelude'. One consequence of this design is that we must +-- export the 'Control.Lens.Internal.Doctest' module, as GHCi (and therefore +-- @cabal-docspec@) won't be able to import it otherwise. Despite this technical +-- oddity, this module should be thought of as internal to @lens@. +module Control.Lens.Internal.Doctest + ( head + , tail + ) where + +import Prelude hiding (head, tail) + +head :: [a] -> a +head (x:_) = x +head [] = error "head: empty list" + +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = error "tail: empty list" diff --git a/src/Control/Lens/Internal/Exception.hs b/src/Control/Lens/Internal/Exception.hs --- a/src/Control/Lens/Internal/Exception.hs +++ b/src/Control/Lens/Internal/Exception.hs @@ -2,15 +2,11 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# 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" @@ -35,16 +31,12 @@ import Control.Lens.Fold import Control.Lens.Getter import Control.Monad.Catch as Catch +import Data.Kind import Data.Monoid import Data.Proxy import Data.Reflection import Data.Typeable --- 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 ------------------------------------------------------------------------------ @@ -53,7 +45,7 @@ -- -- This lets us write combinators to build handlers that are agnostic about the choice of -- which of these they use. -class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where +class Handleable e (m :: Type -> Type) (h :: Type -> Type) | h -> e m where -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Type.Prism' (or any 'Getter', really). -- -- @ @@ -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) ------------------------------------------------------------------------------ @@ -152,7 +144,7 @@ ------------------------------------------------------------------------------ -- | There was an 'Exception' caused by abusing the internals of a 'Handler'. -data HandlingException = HandlingException deriving (Show,Typeable) +data HandlingException = HandlingException deriving Show instance Exception HandlingException @@ -166,27 +158,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 +newtype Handling a s (m :: Type -> Type) = Handling a type role Handling representational nominal nominal -#else --- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap. --- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep. -instance (Typeable a, Typeable s, Typeable1 m) => Typeable (Handling a s m) where - typeOf _ = mkTyConApp handlingTyCon - [ typeOf (undefined :: a) - , typeOf (undefined :: s) - , typeOf1 (undefined :: m a) - ] - {-# INLINE typeOf #-} -handlingTyCon :: TyCon -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,13 +169,9 @@ 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 + => Exception (Handling a (s :: Type) m) where toException _ = SomeException HandlingException {-# INLINE toException #-} fromException = fmap Handling . reflect (Proxy :: Proxy s) diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs --- a/src/Control/Lens/Internal/FieldTH.hs +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -1,5 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#else +{-# LANGUAGE TemplateHaskell #-} +#endif #ifdef TRUSTWORTHY # if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-} @@ -34,6 +39,7 @@ import Control.Lens.At import Control.Lens.Fold +import Control.Lens.Indexed import Control.Lens.Internal.TH import Control.Lens.Internal.Prelude import Control.Lens.Lens @@ -48,8 +54,9 @@ import Language.Haskell.TH.Lens import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D -import Data.Maybe (isJust,maybeToList) -import Data.List (nub, findIndices) +import qualified Language.Haskell.TH.Datatype.TyVarBndr as D +import Data.Maybe (fromMaybe,isJust,maybeToList) +import Data.List (nub) import Data.Either (partitionEithers) import Data.Semigroup (Any (..)) import Data.Set.Lens @@ -83,8 +90,8 @@ fieldCons <- traverse normalizeConstructor cons 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) + allDefs = setOf (normFieldLabels . folded . _1) defCons + T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of @@ -94,17 +101,17 @@ 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 normFieldLabels = traverse . _2 . traverse . _1 -- Map a (possibly missing) field's name to zero-to-many optic definitions - expandName :: [Name] -> Maybe Name -> [DefName] - expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList + expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)] + expandName allFields mName = (\x -> (x, mName)) <$> (maybeToList mName >>= _fieldToDef rules tyName allFields) -- | Normalized the Con type into a uniform positional representation, -- eliminating the variance between records, infix constructors, and normal @@ -140,15 +147,15 @@ -- type of clauses to generate and the type to annotate the declaration -- with. buildScaffold :: - LensRules -> - Type {- ^ outer type -} -> - [(Name, [([DefName], Type)])] {- ^ normalized constructors -} -> - DefName {- ^ target definition -} -> - Q (OpticType, OpticStab, [(Name, Int, [Int])]) + LensRules -> + Type {- ^ outer type -} -> + [(Name, [([(DefName, Maybe Name)], Type)])] {- ^ normalized constructors -} -> + DefName {- ^ target definition -} -> + Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]) {- ^ optic type, definition type, field count, target fields -} buildScaffold rules s cons defName = - do (s',t,a,b) <- buildStab s (concatMap snd consForDef) + do (s',t,a,b) <- buildStab s (concatMap snd (consForDef <&> _2 . mapped . _Right %~ snd)) let defType | Just (_,cx,a') <- preview _ForallT a = @@ -183,29 +190,27 @@ return (opticType, defType, scaffolds) where - consForDef :: [(Name, [Either Type Type])] + consForDef :: [(Name, [Either Type (Maybe Name, Type)])] consForDef = over (mapped . _2 . mapped) categorize cons - scaffolds :: [(Name, Int, [Int])] - scaffolds = [ (n, length ts, rightIndices ts) | (n,ts) <- consForDef ] - - rightIndices :: [Either Type Type] -> [Int] - rightIndices = findIndices (has _Right) + scaffolds :: [(Name, Int, [(Maybe Name, Int)])] + scaffolds = [ (n, length ts, (\(a, b) -> (b, a)) <$> ts ^@.. folded <. _Right . _1) | (n,ts) <- consForDef ] -- Right: types for this definition -- Left : other types - categorize :: ([DefName], Type) -> Either Type Type - categorize (defNames, t) - | defName `elem` defNames = Right t - | otherwise = Left t + categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type) + categorize (defNames, t) = + case lookup defName defNames of + Just c -> Right (c, t) + Nothing -> Left t lensCase :: Bool lensCase = all (\x -> lengthOf (_2 . folded . _Right) x == 1) consForDef isoCase :: Bool isoCase = case scaffolds of - [(_,1,[0])] -> True - _ -> False + [(_,1,[(_, 0)])] -> True + _ -> False data OpticStab = OpticStab Name Type Type Type Type @@ -241,23 +246,66 @@ 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) where (fixedFields, targetFields) = partitionEithers categorizedFields - fixedTypeVars = setOf typeVars fixedFields - unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars + fixedTypeVars, unfixedTypeVars :: Set Name + fixedTypeVars = closeOverKinds $ setOf typeVars fixedFields + unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars + -- Compute the kind variables that appear in the kind of a type variable + -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a + -- type variable binder lacks an explicit kind annotation, this + -- conservatively assumes that there are no kind variables. For example, + -- @kindVarsOfTvb (y) = (y, {})@. + kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name) + kindVarsOfTvb = D.elimTV (\n -> (n, Set.empty)) + (\n k -> (n, setOf typeVars k)) + + -- For each type variable name that appears in @s@, map to the kind variables + -- that appear in that type variable's kind. + sKindVarMap :: Map Name (Set Name) + sKindVarMap = Map.fromList $ map kindVarsOfTvb $ D.freeVariablesWellScoped [s] + + lookupSKindVars :: Name -> Set Name + lookupSKindVars n = fromMaybe Set.empty $ Map.lookup n sKindVarMap + + -- Consider this example (adapted from #972): + -- + -- data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int } + -- $(makeLenses ''Dart) + -- + -- When generating a Lens for `direction`, the type variable `s` should be + -- fixed. But note that (s :: k), and as a result, the kind variable `k` + -- needs to be fixed as well. This is because a type like this would be + -- ill kinded: + -- + -- direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction + -- + -- However, only `s` is mentioned syntactically in the type of `_arc`, so we + -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this + -- with `closeOverKinds`, which does the following: + -- + -- 1. Use freeVariablesWellScoped to compute the free type variables of + -- `Dart (s :: k)`, which gives us `(s :: k)`. + -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up + -- the kind variables in the type variable's kind. In the case of `s`, + -- the only kind variable is `k`. + -- 3. Add these kind variables to the set of fixed type variables. + closeOverKinds :: Set Name -> Set Name + closeOverKinds st = foldl' Set.union Set.empty (Set.map lookupSKindVars st) `Set.union` st + -- | Build the signature and definition for a single field optic. -- In the case of a singleton constructor irrefutable matches are -- used to enable the resulting lenses to be used on a bottom value. makeFieldOptic :: LensRules -> - (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) -> + (DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])) -> HasFieldClasses [Dec] makeFieldOptic rules (defName, (opticType, defType, cons)) = do locals <- get @@ -298,7 +346,7 @@ Name -> Name -> Type {- ^ Outer 's' type -} -> - [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> + [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> HasFieldClasses [Dec] makeClassyDriver rules className methodName s defs = T.sequenceA (cls ++ inst) @@ -313,18 +361,19 @@ Name -> Name -> Type {- ^ Outer 's' type -} -> - [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> + [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> DecQ makeClassyClass className methodName s defs = do let ss = map (stabToS . view (_2 . _2)) defs (sub,s') <- unifyTypes (s : ss) c <- newName "c" - let vars = toListOf typeVars s' + let vars = D.changeTVFlags bndrReq $ 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 +382,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)] @@ -345,7 +394,7 @@ Name -> Name -> Type {- ^ Outer 's' type -} -> - [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] -> + [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> HasFieldClasses Dec makeClassyInstance rules className methodName s defs = do methodss <- traverse (makeFieldOptic rules') defs @@ -355,8 +404,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 +416,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]) @@ -388,19 +437,21 @@ containsTypeFamilies = go <=< D.resolveTypeSynonyms where - go (ConT nm) = has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm + go :: Type -> Q Bool + go (ConT nm) = + -- Note that the call to `reify` can fail if `nm` is not yet defined. + -- (This can actually happen if `nm` is declared in a Template Haskell + -- quote.) If this fails, there is no way to tell if the type contains + -- type families, so we recover and conservatively assume that is does not + -- contain any. + recover + (pure False) + (has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm) go ty = or <$> traverse go (ty ^.. plate) -- We want to catch type families, but not *data* families. See #799. _TypeFamilyD :: Getting Any Dec () _TypeFamilyD = _OpenTypeFamilyD.united <> _ClosedTypeFamilyD.united - where -#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 @@ -418,20 +469,21 @@ ------------------------------------------------------------------------ -makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ] +makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ] makeFieldClauses rules opticType cons = case opticType of IsoType -> [ makeIsoClause conName | (conName, _, _) <- cons ] - GetterType -> [ makeGetterClause conName fieldCount fields + GetterType -> [ makeGetterClause conName fieldCount (snd <$> fields) | (conName, fieldCount, fields) <- cons ] - LensType -> [ makeFieldOpticClause conName fieldCount fields irref + LensType -> [ makeFieldOpticClause conName fieldCount fields irref recSyn | (conName, fieldCount, fields) <- cons ] where irref = _lazyPatterns rules && length cons == 1 + recSyn = _recordSyntax rules && length cons == 1 @@ -454,16 +506,20 @@ makeGetterClause conName fieldCount fields = do f <- newName "f" xs <- newNames "x" (length fields) + xs' <- + case xs of + (x:xs') -> pure (x :| xs') + [] -> fail "makeGetterClause: Internal check failed" let pats (i:is) (y:ys) | i `elem` fields = varP y : pats is ys | otherwise = wildP : pats is (y:ys) pats is _ = map (const wildP) is - fxs = [ appE (varE f) (varE x) | x <- xs ] + (fx :| fxs) = fmap (appE (varE f) . varE) xs' body = foldl (\a b -> appsE [varE apValName, a, b]) - (appE (varE phantomValName) (head fxs)) - (tail fxs) + (appE (varE phantomValName) fx) + fxs -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn clause [varP f, conP conName (pats [0..fieldCount - 1] xs)] @@ -473,15 +529,25 @@ -- | Build a clause that updates the field at the given indexes -- When irref is 'True' the value with me matched with an irrefutable -- pattern. This is suitable for Lens and Traversal construction -makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ -makeFieldOpticClause conName fieldCount [] _ = +makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ +makeFieldOpticClause conName fieldCount [] _ _ = makePureClause conName fieldCount -makeFieldOpticClause conName fieldCount (field:fields) irref = +makeFieldOpticClause _ _ [(Just fieldName, _)] _ True = + do f <- newName "f" + r <- newName "r" + x <- newName "x" + let body = appsE [ [| fmap |] + , lamE [varP x] (recUpdE (varE r) [(,) fieldName <$> varE x]) + , varE f `appE` (varE fieldName `appE` varE r) + ] + clause [varP f, varP r] (normalB body) [] +makeFieldOpticClause conName fieldCount ((_, field):fieldsWithNames) irref _ = do f <- newName "f" xs <- newNames "x" fieldCount - ys <- newNames "y" (1 + length fields) + ys <- newNames "y" (1 + length fieldsWithNames) - let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) + let fields = snd <$> fieldsWithNames + xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) mkFx i = appE (varE f) (varE (xs !! i)) @@ -557,18 +623,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 @@ -592,6 +653,7 @@ , _allowIsos :: Bool , _allowUpdates :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold) , _lazyPatterns :: Bool + , _recordSyntax :: Bool , _fieldToDef :: FieldNamer -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names , _classyLenses :: ClassyNamer @@ -627,23 +689,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 @@ -2,9 +2,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif +{-# OPTIONS_GHC -Wno-redundant-constraints #-} ----------------------------------------------------------------------------- -- | @@ -23,8 +21,6 @@ , Traversed(..) , TraversedF(..) , Sequenced(..) - , Max(..), getMax - , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost , ReifiedMonoid(..) @@ -42,10 +38,6 @@ import qualified Data.List.NonEmpty as NonEmpty -#ifdef HLINT -{-# ANN module "HLint: ignore Avoid lambda" #-} -#endif - ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------ @@ -60,8 +52,10 @@ instance (Contravariant f, Applicative f) => Monoid (Folding f a) where mempty = Folding noEffect {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) Folding fr `mappend` Folding fs = Folding (fr *> fs) {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ -- Traversed @@ -80,8 +74,10 @@ instance Applicative f => Monoid (Traversed a f) where mempty = Traversed (pure (error "Traversed: value used")) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) Traversed ma `mappend` Traversed mb = Traversed (ma *> mb) {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ -- TraversedF @@ -99,8 +95,10 @@ instance (Apply f, Applicative f) => Monoid (TraversedF a f) where mempty = TraversedF (pure (error "TraversedF: value used")) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) TraversedF ma `mappend` TraversedF mb = TraversedF (ma *> mb) {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ -- Sequenced @@ -120,62 +118,10 @@ instance Monad m => Monoid (Sequenced a m) where mempty = Sequenced (return (error "Sequenced: value used")) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) {-# INLINE mappend #-} - ------------------------------------------------------------------------------- --- 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 #-} +#endif ------------------------------------------------------------------------------ -- NonEmptyDList @@ -195,24 +141,26 @@ data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) instance Semigroup (Leftmost a) where - (<>) = mappend - {-# INLINE (<>) #-} - -instance Monoid (Leftmost a) where - mempty = LPure - {-# INLINE mempty #-} - mappend x y = LStep $ case x of + x <> y = LStep $ case x of LPure -> y LLeaf _ -> x LStep x' -> case y of -- The last two cases make firstOf produce a Just as soon as any element -- is encountered, and possibly serve as a micro-optimisation; this - -- behaviour can be disabled by replacing them with _ -> mappend x y'. + -- behaviour can be disabled by replacing them with _ -> x <> y'. -- Note that this means that firstOf (backwards folded) [1..] is Just _|_. LPure -> x' LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x') LStep y' -> mappend x' y' +instance Monoid (Leftmost a) where + mempty = LPure + {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + {-# INLINE mappend #-} +#endif + -- | Extract the 'Leftmost' element. This will fairly eagerly determine that it can return 'Just' -- the moment it sees any element at all. getLeftmost :: Leftmost a -> Maybe a @@ -224,23 +172,25 @@ data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) instance Semigroup (Rightmost a) where - (<>) = mappend - {-# INLINE (<>) #-} - -instance Monoid (Rightmost a) where - mempty = RPure - {-# INLINE mempty #-} - mappend x y = RStep $ case y of + x <> y = RStep $ case y of RPure -> x RLeaf _ -> y RStep y' -> case x of -- The last two cases make lastOf produce a Just as soon as any element -- is encountered, and possibly serve as a micro-optimisation; this - -- behaviour can be disabled by replacing them with _ -> mappend x y'. + -- behaviour can be disabled by replacing them with _ -> x <> y'. -- Note that this means that lastOf folded [1..] is Just _|_. RPure -> y' RLeaf a -> RLeaf $ fromMaybe a (getRightmost y') RStep x' -> mappend x' y' + +instance Monoid (Rightmost a) where + mempty = RPure + {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + {-# INLINE mappend #-} +#endif -- | Extract the 'Rightmost' element. This will fairly eagerly determine that it can return 'Just' -- the moment it sees any element at all. diff --git a/src/Control/Lens/Internal/Indexed.hs b/src/Control/Lens/Internal/Indexed.hs --- a/src/Control/Lens/Internal/Indexed.hs +++ b/src/Control/Lens/Internal/Indexed.hs @@ -1,14 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | @@ -52,14 +50,12 @@ 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) @@ -288,10 +282,12 @@ mempty = Indexing $ \i -> (i, mempty) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend (Indexing mx) (Indexing my) = Indexing $ \i -> case mx i of (j, x) -> case my j of ~(k, y) -> (k, mappend x y) {-# INLINE mappend #-} +#endif -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. 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,20 +19,26 @@ ) where import Data.Profunctor -#ifndef SAFE import Data.Profunctor.Unsafe -import Control.Lens.Internal.Coerce + +import qualified Data.ByteString as StrictB +import qualified Data.ByteString.Lazy as LazyB +import Data.Coerce +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as StrictT +import qualified Data.Text.Lazy as LazyT +import qualified Data.Vector as Vector +import qualified Data.Vector.Primitive as Prim +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Storable as Storable +import qualified Data.Vector.Unboxed as Unbox +import Data.Vector.Unboxed (Unbox) +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict #endif -import Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB -import Data.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.Sequence as Seq +import Data.Sequence (Seq) +import Foreign.Storable (Storable) ------------------------------------------------------------------------------ -- Isomorphism: Exchange @@ -52,12 +59,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 @@ -99,3 +103,8 @@ instance Storable a => Reversing (Storable.Vector a) where reversing = Storable.reverse + +#if MIN_VERSION_vector(0,13,2) +instance Reversing (VectorStrict.Vector a) where + reversing = VectorStrict.reverse +#endif diff --git a/src/Control/Lens/Internal/Level.hs b/src/Control/Lens/Internal/Level.hs --- a/src/Control/Lens/Internal/Level.hs +++ b/src/Control/Lens/Internal/Level.hs @@ -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 @@ -86,6 +89,27 @@ go Zero = pure Zero {-# INLINE traverse #-} +instance FunctorWithIndex i (Level i) where + imap f = go where + go (Two n l r) = Two n (go l) (go r) + go (One i a) = One i (f i a) + go Zero = Zero + {-# INLINE imap #-} + +instance FoldableWithIndex i (Level i) where + ifoldMap f = go where + go (Two _ l r) = go l `mappend` go r + go (One i a) = f i a + go Zero = mempty + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i (Level i) where + itraverse f = go where + go (Two n l r) = Two n <$> go l <*> go r + go (One i a) = One i <$> f i a + go Zero = pure Zero + {-# INLINE itraverse #-} + ------------------------------------------------------------------------------ -- Generating Levels ------------------------------------------------------------------------------ @@ -103,10 +127,12 @@ instance Monoid (Deepening i a) where mempty = Deepening $ \ _ k -> k Zero False {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend (Deepening l) (Deepening r) = Deepening $ \ n k -> case n of 0 -> k Zero True _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) {-# INLINE mappend #-} +#endif -- | Generate the leaf of a given 'Deepening' based on whether or not we're at the correct depth. deepening :: i -> a -> Deepening i a diff --git a/src/Control/Lens/Internal/List.hs b/src/Control/Lens/Internal/List.hs --- a/src/Control/Lens/Internal/List.hs +++ b/src/Control/Lens/Internal/List.hs @@ -13,14 +13,16 @@ ------------------------------------------------------------------------------- module Control.Lens.Internal.List ( ordinalNub + , stripSuffix ) where +import Control.Monad (guard) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -#ifdef HLINT -{-# ANN module "HLint: ignore Redundant bracket" #-} -#endif +--- $setup +--- >>> :set -XNoOverloadedStrings +--- >>> import Control.Lens.Internal.List -- | Return the the subset of given ordinals within a given bound -- and in order of the first occurrence seen. @@ -42,3 +44,30 @@ where outOfBounds = x < 0 || l <= x notUnique = x `IntSet.member` seen + +-- | \(\mathcal{O}(\min(m,n))\). The 'stripSuffix' function drops the given +-- suffix from a list. It returns 'Nothing' if the list did not end with the +-- suffix given, or 'Just' the list after the suffix, if it does. +-- +-- >>> stripSuffix "bar" "foobar" +-- Just "foo" +-- +-- >>> stripSuffix "foo" "foo" +-- Just "" +-- +-- >>> stripSuffix "bar" "barfoo" +-- Nothing +-- +-- >>> stripSuffix "foo" "barfoobaz" +-- Nothing +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix qs xs0 = go xs0 zs + where + zs = drp qs xs0 + drp (_:ps) (_:xs) = drp ps xs + drp [] xs = xs + drp _ [] = [] + go (_:xs) (_:ys) = go xs ys + go xs [] = zipWith const xs0 zs <$ guard (xs == qs) + go [] _ = Nothing -- impossible +{-# INLINE stripSuffix #-} diff --git a/src/Control/Lens/Internal/Magma.hs b/src/Control/Lens/Internal/Magma.hs --- a/src/Control/Lens/Internal/Magma.hs +++ b/src/Control/Lens/Internal/Magma.hs @@ -5,10 +5,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma @@ -42,6 +41,10 @@ import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Data.Functor.Apply +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Kind +import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Magma @@ -55,10 +58,8 @@ MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a Magma :: i -> a -> Magma i b b a -#if __GLASGOW_HASKELL__ >= 707 -- note the 3rd argument infers as phantom, but that would be unsound type role Magma representational nominal nominal nominal -#endif instance Functor (Magma i t b) where fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y) @@ -78,6 +79,27 @@ traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x traverse f (Magma i a) = Magma i <$> f a +instance FunctorWithIndex i (Magma i t b) where + imap f (MagmaAp x y) = MagmaAp (imap f x) (imap f y) + imap _ (MagmaPure x) = MagmaPure x + imap f (MagmaFmap xy x) = MagmaFmap xy (imap f x) + imap f (Magma i a) = Magma i (f i a) + {-# INLINE imap #-} + +instance FoldableWithIndex i (Magma i t b) where + ifoldMap f (MagmaAp x y) = ifoldMap f x `mappend` ifoldMap f y + ifoldMap _ MagmaPure{} = mempty + ifoldMap f (MagmaFmap _ x) = ifoldMap f x + ifoldMap f (Magma i a) = f i a + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i (Magma i t b) where + itraverse f (MagmaAp x y) = MagmaAp <$> itraverse f x <*> itraverse f y + itraverse _ (MagmaPure x) = pure (MagmaPure x) + itraverse f (MagmaFmap xy x) = MagmaFmap xy <$> itraverse f x + itraverse f (Magma i a) = Magma i <$> f i a + {-# INLINE itraverse #-} + instance (Show i, Show a) => Show (Magma i t b a) where showsPrec d (MagmaAp x y) = showParen (d > 4) $ showsPrec 4 x . showString " <*> " . showsPrec 5 y @@ -209,10 +231,8 @@ -- -- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant', -- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma' -data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) -#if __GLASGOW_HASKELL__ >= 707 +data TakingWhile p (g :: Type -> Type) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) type role TakingWhile nominal nominal nominal nominal nominal -#endif -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. runTakingWhile :: 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 @@ -33,6 +33,8 @@ #if !MIN_VERSION_base(4,10,0) , liftA2 #endif + -- * Data.Coerce + , Coercible, coerce -- * Data.Contravariant , Contravariant (..), phantom -- * Data.Monoid @@ -55,22 +57,15 @@ import Prelude hiding ( userError -- hiding something always helps with CPP -#if MIN_VERSION_base(4,8,0) , Applicative (..) , Foldable (..) , Traversable (..) , Monoid (..) , (<$>), (<$) -#else - , foldr, foldl, length, elem, null - , mapM, sequence -#endif #if MIN_VERSION_base(4,13,0) , Semigroup (..) #endif -#if MIN_VERSION_base(4,8,0) , Word -#endif ) -- Prelude @@ -82,10 +77,8 @@ import Data.Word (Word) -- Extras -#if MIN_VERSION_base(4,8,0) import Data.Function ((&)) import Data.Foldable (length, null) -#endif #if !MIN_VERSION_base(4,10,0) import Control.Applicative (liftA2) @@ -96,6 +89,7 @@ #endif import Control.Applicative (Alternative (..), Const (..), WrappedMonad (..), ZipList (..)) +import Data.Coerce (Coercible, coerce) import Data.Functor.Compose (Compose (..)) import Data.Functor.Contravariant (Contravariant (..), phantom) import Data.Functor.Identity (Identity (..)) @@ -109,48 +103,9 @@ import Data.Tagged (Tagged (..)) import Data.Void (Void, absurd) --- $setup --- >>> import Control.Lens --- >>> import Control.Monad.State --- >>> import Debug.SimpleReflect.Expr --- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h) --- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f --- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g --- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h - -#if !(MIN_VERSION_base(4,8,0)) --- | Passes the result of the left side to the function on the right side (forward pipe operator). --- --- This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed --- for inference. Here it is supplied for notational convenience and given a precedence that allows it --- to be nested inside uses of ('$'). --- --- >>> a & f --- f a --- --- >>> "hello" & length & succ --- 6 --- --- This combinator is commonly used when applying multiple 'Lens' operations in sequence. --- --- >>> ("hello","world") & _1.element 0 .~ 'j' & _1.element 4 .~ 'y' --- ("jelly","world") --- --- This reads somewhat similar to: --- --- >>> flip execState ("hello","world") $ do _1.element 0 .= 'j'; _1.element 4 .= 'y' --- ("jelly","world") -(&) :: a -> (a -> b) -> b -a & f = f a -{-# INLINE (&) #-} -infixl 1 & - -null :: Foldable t => t a -> Bool -null = foldr (\_ _ -> False) True - -length :: Foldable t => t a -> Int -length = foldl' (\c _ -> c+1) 0 -#endif +-- TraversableWithIndex instances for tagged, vector and unordered-containers +-- We import this here, so the instances propagate through all (most) of @lens@. +import Data.Functor.WithIndex.Instances () #if !(MIN_VERSION_base(4,11,0)) -- | Infix flipped 'fmap'. 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 @@ -18,10 +18,6 @@ import Control.Lens.Internal.Prelude -#ifndef SAFE -import Control.Lens.Internal.Coerce -#endif - ------------------------------------------------------------------------------ -- Prism: Market ------------------------------------------------------------------------------ @@ -45,12 +41,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.changeTVFlags bndrReq $ 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)) @@ -516,7 +513,7 @@ -- | Compute a prism's name with a special case for when the type -- constructor matches one of the value constructors. -- --- The overlapping flag wil be 'True' in the event that: +-- The overlapping flag will be 'True' in the event that: -- -- 1. We are generating the name of a classy prism for a -- data type, and @@ -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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} #ifdef TRUSTWORTHY # if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-} @@ -19,17 +20,25 @@ -- Portability : non-portable -- ---------------------------------------------------------------------------- -module Control.Lens.Internal.TH where +module Control.Lens.Internal.TH + ( module Control.Lens.Internal.TH +#if MIN_VERSION_template_haskell(2,21,0) || MIN_VERSION_th_abstraction(0,6,0) + , D.TyVarBndrVis + , D.bndrReq +#endif + ) where +import Control.Lens.Iso +import Control.Lens.Prism +import Control.Lens.Review +import Control.Lens.Type +import Control.Lens.Wrapped import Data.Functor.Contravariant -import Language.Haskell.TH -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) -#endif +import Data.Set (Set) +import Language.Haskell.TH +import qualified Language.Haskell.TH.Datatype as D +import qualified Language.Haskell.TH.Datatype.TyVarBndr as D -- | Apply arguments to a type constructor appsT :: TypeQ -> [TypeQ] -> TypeQ @@ -58,19 +67,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] ] @@ -95,123 +91,173 @@ go acc (ForallT _ _ ty) = go acc ty go acc (AppT ty1 ty2) = go (ty2:acc) ty1 go acc (SigT ty _) = go acc ty -#if MIN_VERSION_template_haskell(2,11,0) go acc (ParensT ty) = go acc ty -#endif #if MIN_VERSION_template_haskell(2,15,0) go acc (AppKindT ty _) = go acc ty #endif go acc ty = (ty, acc) ------------------------------------------------------------------------- --- Manually quoted names ------------------------------------------------------------------------- --- By manually generating these names we avoid needing to use the --- TemplateHaskell language extension when compiling the lens library. --- This allows the library to be used in stage1 cross-compilers. +-- Construct a 'Type' using the datatype's type constructor and type +-- parameters. Unlike 'D.datatypeType', kind signatures are preserved to +-- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more +-- details on this.) +datatypeTypeKinded :: D.DatatypeInfo -> Type +datatypeTypeKinded di + = foldl AppT (ConT (D.datatypeName di)) + $ dropSigsIfNonDataFam di + $ D.datatypeInstTypes di -lensPackageKey :: String -#ifdef CURRENT_PACKAGE_KEY -lensPackageKey = CURRENT_PACKAGE_KEY -#else -lensPackageKey = "lens-" ++ showVersion version +-- | In an effort to prevent users from having to enable KindSignatures every +-- time that they use lens' TH functionality, we strip off reified kind +-- annotations from when: +-- +-- 1. The kind of a type does not contain any kind variables. If it *does* +-- contain kind variables, we want to preserve them so that we can generate +-- type signatures that preserve the dependency order of kind and type +-- variables. (The data types in test/T917.hs contain examples where this +-- is important.) This will require enabling `PolyKinds`, but since +-- `PolyKinds` implies `KindSignatures`, we can at least accomplish two +-- things at once. +-- 2. The data type is not an instance of a data family. We make an exception +-- for data family instances, since the presence or absence of a kind +-- annotation can be the difference between typechecking or not. +-- (See T917DataFam in tests/T917.hs for an example.) Moreover, the +-- `TypeFamilies` extension implies `KindSignatures`. +dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type] +dropSigsIfNonDataFam di + | isDataFamily (D.datatypeVariant di) = id + | otherwise = map dropSig + where + dropSig :: Type -> Type + dropSig (SigT t k) | null (D.freeVariables k) = t + dropSig t = t + +-- | Template Haskell wants type variables declared in a forall, so +-- we find all free type variables in a given type and declare them. +quantifyType :: Cxt -> Type -> Type +quantifyType = quantifyType' Set.empty + +-- | This function works like 'quantifyType' except that it takes +-- a list of variables to exclude from quantification. +quantifyType' :: Set Name -> Cxt -> Type -> Type +quantifyType' exclude c t = ForallT vs c t + where + vs = filter (\tvb -> D.tvName tvb `Set.notMember` exclude) + $ D.changeTVFlags D.SpecifiedSpec + $ D.freeVariablesWellScoped (t:c) -- stable order + +-- | Convert a 'TyVarBndr' into its corresponding 'Type'. +tvbToType :: D.TyVarBndr_ flag -> Type +tvbToType = D.elimTV VarT (SigT . VarT) + +-- | Peel off a kind signature from a Type (if it has one). +unSigT :: Type -> Type +unSigT (SigT t _) = t +unSigT t = t + +isDataFamily :: D.DatatypeVariant -> Bool +isDataFamily D.Datatype = False +isDataFamily D.Newtype = False +isDataFamily D.DataInstance = True +isDataFamily D.NewtypeInstance = True +#if MIN_VERSION_th_abstraction(0,5,0) +isDataFamily D.TypeData = False #endif -mkLensName_tc :: String -> String -> Name -mkLensName_tc = mkNameG_tc lensPackageKey +#if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0)) +type TyVarBndrVis = D.TyVarBndr_ () -mkLensName_v :: String -> String -> Name -mkLensName_v = mkNameG_v lensPackageKey +bndrReq :: () +bndrReq = () +#endif +------------------------------------------------------------------------ +-- TH-quoted names +------------------------------------------------------------------------ +-- Note that this module only TemplateHaskellQuotes, not TemplateHaskell, +-- which makes lens able to be used in stage1 cross-compilers. + traversalTypeName :: Name -traversalTypeName = mkLensName_tc "Control.Lens.Type" "Traversal" +traversalTypeName = ''Traversal traversal'TypeName :: Name -traversal'TypeName = mkLensName_tc "Control.Lens.Type" "Traversal'" +traversal'TypeName = ''Traversal' lensTypeName :: Name -lensTypeName = mkLensName_tc "Control.Lens.Type" "Lens" +lensTypeName = ''Lens lens'TypeName :: Name -lens'TypeName = mkLensName_tc "Control.Lens.Type" "Lens'" +lens'TypeName = ''Lens' isoTypeName :: Name -isoTypeName = mkLensName_tc "Control.Lens.Type" "Iso" +isoTypeName = ''Iso iso'TypeName :: Name -iso'TypeName = mkLensName_tc "Control.Lens.Type" "Iso'" +iso'TypeName = ''Iso' getterTypeName :: Name -getterTypeName = mkLensName_tc "Control.Lens.Type" "Getter" +getterTypeName = ''Getter foldTypeName :: Name -foldTypeName = mkLensName_tc "Control.Lens.Type" "Fold" +foldTypeName = ''Fold prismTypeName :: Name -prismTypeName = mkLensName_tc "Control.Lens.Type" "Prism" +prismTypeName = ''Prism prism'TypeName :: Name -prism'TypeName = mkLensName_tc "Control.Lens.Type" "Prism'" +prism'TypeName = ''Prism' reviewTypeName :: Name -reviewTypeName = mkLensName_tc "Control.Lens.Type" "Review" +reviewTypeName = ''Review wrappedTypeName :: Name -wrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Wrapped" +wrappedTypeName = ''Wrapped unwrappedTypeName :: Name -unwrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Unwrapped" +unwrappedTypeName = ''Unwrapped rewrappedTypeName :: Name -rewrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Rewrapped" +rewrappedTypeName = ''Rewrapped _wrapped'ValName :: Name -_wrapped'ValName = mkLensName_v "Control.Lens.Wrapped" "_Wrapped'" +_wrapped'ValName = '_Wrapped' isoValName :: Name -isoValName = mkLensName_v "Control.Lens.Iso" "iso" +isoValName = 'iso prismValName :: Name -prismValName = mkLensName_v "Control.Lens.Prism" "prism" +prismValName = 'prism untoValName :: Name -untoValName = mkLensName_v "Control.Lens.Review" "unto" +untoValName = 'unto phantomValName :: Name -phantomValName = mkLensName_v "Control.Lens.Internal.TH" "phantom2" +phantomValName = 'phantom2 phantom2 :: (Functor f, Contravariant f) => f a -> f b phantom2 = phantom {-# INLINE phantom2 #-} composeValName :: Name -composeValName = mkNameG_v "base" "GHC.Base" "." +composeValName = '(.) idValName :: Name -idValName = mkNameG_v "base" "GHC.Base" "id" +idValName = 'id fmapValName :: Name -fmapValName = mkNameG_v "base" "GHC.Base" "fmap" +fmapValName = 'fmap -#if MIN_VERSION_base(4,8,0) pureValName :: Name -pureValName = mkNameG_v "base" "GHC.Base" "pure" - -apValName :: Name -apValName = mkNameG_v "base" "GHC.Base" "<*>" -#else -pureValName :: Name -pureValName = mkNameG_v "base" "Control.Applicative" "pure" +pureValName = 'pure apValName :: Name -apValName = mkNameG_v "base" "Control.Applicative" "<*>" -#endif +apValName = '(<*>) rightDataName :: Name -rightDataName = mkNameG_d "base" "Data.Either" "Right" +rightDataName = 'Right leftDataName :: Name -leftDataName = mkNameG_d "base" "Data.Either" "Left" +leftDataName = 'Left ------------------------------------------------------------------------ @@ -219,26 +265,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 @@ -4,7 +4,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Zoom @@ -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 @@ -153,10 +153,12 @@ instance Monoid a => Monoid (May a) where mempty = May (Just mempty) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) May Nothing `mappend` _ = May Nothing _ `mappend` May Nothing = May Nothing May (Just a) `mappend` May (Just b) = May (Just (mappend a b)) {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ -- FocusingMay @@ -195,10 +197,12 @@ instance Monoid a => Monoid (Err e a) where mempty = Err (Right mempty) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) Err (Left e) `mappend` _ = Err (Left e) _ `mappend` Err (Left e) = Err (Left e) Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b)) {-# INLINE mappend #-} +#endif ------------------------------------------------------------------------------ -- FocusingErr @@ -238,10 +242,12 @@ instance (Applicative f, Monoid a, Monad m) => Monoid (Freed f m a) where mempty = Freed $ Pure mempty +#if !(MIN_VERSION_base(4,11,0)) Freed (Pure a) `mappend` Freed (Pure b) = Freed $ Pure $ a `mappend` b Freed (Pure a) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) (pure $ return a) g Freed (Free f) `mappend` Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 mappend) f (pure $ return b) Freed (Free f) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) f g +#endif ------------------------------------------------------------------------------ -- FocusingFree @@ -288,8 +294,10 @@ instance (Monad m, Monoid r) => Monoid (Effect m r a) where mempty = Effect (return mempty) {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) {-# INLINE mappend #-} +#endif instance (Apply m, Semigroup r) => Apply (Effect m r) where Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb) 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,16 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE PolyKinds #-} +#else {-# LANGUAGE TypeInType #-} #endif @@ -51,25 +49,16 @@ , enum , curried, uncurried , flipped - , Swapped(..) -#if __GLASGOW_HASKELL__ >= 710 + , swapped , pattern Swapped -#endif - , Strict(..) -#if __GLASGOW_HASKELL__ >= 710 + , strict, lazy , pattern Strict , pattern Lazy -#endif - , lazy , Reversing(..) , reversed -#if __GLASGOW_HASKELL__ >= 710 , pattern Reversed -#endif , involuted -#if __GLASGOW_HASKELL__ >= 710 , pattern List -#endif -- ** Uncommon Isomorphisms , magma , imagma @@ -85,75 +74,38 @@ , 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 -#if !(MIN_VERSION_base(4,8,0)) -import Data.Functor -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Coerce (Coercible) -#if __GLASGOW_HASKELL__ < 710 -import Data.Type.Coercion -#endif -#endif +import Data.Coerce -#if __GLASGOW_HASKELL__ >= 710 import qualified GHC.Exts as Exts -#endif - -#if __GLASGOW_HASKELL__ >= 800 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,17 +142,13 @@ -- '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 -- one from @b -> t@ that characterize an 'Iso'. -#if __GLASGOW_HASKELL__ >= 800 withIso :: forall s t a b rep (r :: TYPE rep). AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r -#else -withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r -#endif withIso ai k = case ai (Exchange id Identity) of Exchange sa bt -> k sa (runIdentity #. bt) {-# INLINE withIso #-} @@ -212,7 +160,7 @@ -- -- See 'Control.Lens.Lens.cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this. cloneIso :: AnIso s t a b -> Iso s t a b -cloneIso k = withIso k iso +cloneIso k = withIso k $ \sa bt -> iso sa bt {-# INLINE cloneIso #-} ----------------------------------------------------------------------------- @@ -352,7 +300,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 +311,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 +321,7 @@ -- >>> Map.singleton "hello" Map.empty & at "hello" . non' _Empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- --- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing +-- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing -- fromList [] non' :: APrism' a () -> Iso' (Maybe a) a non' p = iso (fromMaybe def) go where @@ -389,7 +337,7 @@ -- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- --- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing +-- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing -- fromList [] anon :: a -> (a -> Bool) -> Iso' (Maybe a) a anon a p = iso (fromMaybe a) go where @@ -436,124 +384,46 @@ 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 :: Strict s t => t -> s pattern Strict a <- (view strict -> a) where Strict a = review strict a +pattern Lazy :: Strict t s => t -> s pattern Lazy a <- (view lazy -> a) where Lazy a = review lazy a +pattern Swapped :: Swap p => p b a -> p a b pattern Swapped a <- (view swapped -> a) where Swapped a = review swapped a +pattern Reversed :: Reversing t => t -> t pattern Reversed a <- (view reversed -> a) where Reversed a = review reversed a -#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 +431,9 @@ -- 'lazy' = 'from' 'strict' -- @ -- --- See for an example --- use. lazy :: Strict lazy strict => Iso' strict lazy -lazy = from strict +lazy = iso toLazy toStrict +{-# INLINE lazy #-} -- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal. -- @@ -591,10 +460,9 @@ involuted a = iso a a {-# INLINE involuted #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern List :: Exts.IsList l => [Exts.Item l] -> l pattern List a <- (Exts.toList -> a) where List a = Exts.fromList a -#endif ------------------------------------------------------------------------------ -- Magma @@ -700,18 +568,11 @@ 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+ -- -- @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 -# else -coerced l = case sym Coercion :: Coercion a s of - Coercion -> rmap (fmap coerce') l .# coerce -# endif +coerced l = rmap (fmap coerce) l .# coerce {-# 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 @@ -6,7 +6,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} -#if __GLASGOW_HASKELL__ >= 800 + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE PolyKinds #-} +#else {-# LANGUAGE TypeInType #-} #endif @@ -84,18 +87,18 @@ -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (~) + , (<||~), (<&&~), (<<>~), (<<>:~) , (<<%~), (<<.~), (<~) + , (<<||~), (<<&&~), (<<<>~), (<<<>:~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=) + , (<||=), (<&&=), (<<>=), (<<>:=) , (<<%=), (<<.=), (<=) + , (<<||=), (<<&&=), (<<<>=), (<<<>:=) , (<<~) -- * Cloning Lenses @@ -109,8 +112,8 @@ -- * ALens Combinators , storing , (^#) - , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~) - , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=) + , (#~), (#%~), (#%%~), (<#~), (<#%~) + , (#=), (#%=), (#%%=), (<#=), (<#%=) -- * Common Lenses , devoid @@ -140,17 +143,12 @@ import Data.Functor.Reverse import Data.Functor.Yoneda import Data.Semigroup.Traversable -#if __GLASGOW_HASKELL__ >= 800 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 ((:|))) @@ -165,10 +163,10 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^# -infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <%~, <<%~, <<.~, <~ -infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <%=, <<%=, <<.=, <= +infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <<>:~, <%~, <<%~, <<.~, <~, <<<>:~ +infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <<>:=, <%=, <<%=, <<.=, <=, <<<>:= infixr 2 <<~ infixl 1 ??, &~ @@ -223,12 +221,8 @@ {-# INLINE lens #-} -- | Obtain a getter and a setter from a lens, reversing 'lens'. -#if __GLASGOW_HASKELL__ >= 800 withLens :: forall s t a b rep (r :: TYPE rep). ALens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r -#else -withLens :: ALens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r -#endif withLens l f = f (^# l) (flip (storing l)) {-# INLINE withLens #-} @@ -322,14 +316,7 @@ -- ('%%=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Traversal.Traversal' s s a b -> (a -> (r, b)) -> m r -- @ (%%=) :: MonadState s m => Over p ((,) r) s s a b -> p a (r, b) -> m r -#if MIN_VERSION_mtl(2,1,1) l %%= f = State.state (l f) -#else -l %%= f = do - (r, s) <- State.gets (l f) - State.put s - return r -#endif {-# INLINE (%%=) #-} ------------------------------------------------------------------------------- @@ -667,7 +654,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" <= r = l <%= (<> r) {-# INLINE (<<>=) #-} +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and +-- return the result. +-- However, unlike ('<<>~'), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible. +(<<>:~) :: Semigroup m => LensLike ((,) m) s t m m -> m -> s -> (m, t) +l <<>:~ m = l <%~ (m <>) +{-# INLINE (<<>:~) #-} + +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and +-- return the /old/ result. +-- However, unlike ('<<>~'), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible. +(<<<>:~) :: Semigroup m => LensLike' ((,) m) s m -> m -> s -> (m, s) +l <<<>:~ m = l <<%~ (m <>) +{-# INLINE (<<<>:~) #-} + +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into +-- your 'Monad''s state and return the result. +-- However, unlike ('<<>='), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible. +(<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r +l <<>:= r = l <%= (r <>) +{-# INLINE (<<>:=) #-} + +-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into +-- your 'Monad''s state and return the /old/ result. +-- However, unlike ('<<<>='), it is prepended to the head side. +-- +-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible. +(<<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r +l <<<>:= r = l <<%= (r <>) +{-# INLINE (<<<>:=) #-} + ------------------------------------------------------------------------------ -- Arrow operators ------------------------------------------------------------------------------ @@ -1300,14 +1323,7 @@ -- ('%%@=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- @ (%%@=) :: MonadState s m => Over (Indexed i) ((,) r) s s a b -> (i -> a -> (r, b)) -> m r -#if MIN_VERSION_mtl(2,1,0) l %%@= f = State.state (l %%@~ f) -#else -l %%@= f = do - (r, s) <- State.gets (l %%@~ f) - State.put s - return r -#endif {-# INLINE (%%@=) #-} -- | Adjust the target of an 'IndexedLens' returning the intermediate result, or @@ -1331,14 +1347,7 @@ -- ('<<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m a -- @ (<<%@=) :: MonadState s m => Over (Indexed i) ((,) a) s s a b -> (i -> a -> b) -> m a -#if MIN_VERSION_mtl(2,1,0) l <<%@= f = State.state (l (Indexed $ \ i a -> (a, f i a))) -#else -l <<%@= f = do - (r, s) <- State.gets (l (Indexed $ \ i a -> (a, f i a))) - State.put s - return r -#endif {-# INLINE (<<%@=) #-} ------------------------------------------------------------------------------ @@ -1365,35 +1374,35 @@ -- -- >>> ("hello","there") & _2 #~ "world" -- ("hello","world") -( #~ ) :: ALens s t a b -> b -> s -> t -( #~ ) l b s = ipeek b (l sell s) -{-# INLINE ( #~ ) #-} +(#~) :: ALens s t a b -> b -> s -> t +(#~) l b s = ipeek b (l sell s) +{-# INLINE (#~) #-} -- | A version of ('Control.Lens.Setter.%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 #%~ length -- ("hello",5) -( #%~ ) :: ALens s t a b -> (a -> b) -> s -> t -( #%~ ) l f s = ipeeks f (l sell s) -{-# INLINE ( #%~ ) #-} +(#%~) :: ALens s t a b -> (a -> b) -> s -> t +(#%~) l f s = ipeeks f (l sell s) +{-# INLINE (#%~) #-} -- | A version of ('%%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!") -- (5,("hello","world!")) -( #%%~ ) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t -( #%%~ ) l f s = runPretext (l sell s) f -{-# INLINE ( #%%~ ) #-} +(#%%~) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t +(#%%~) l f s = runPretext (l sell s) f +{-# INLINE (#%%~) #-} -- | A version of ('Control.Lens.Setter..=') that works on 'ALens'. -( #= ) :: MonadState s m => ALens s s a b -> b -> m () +(#=) :: MonadState s m => ALens s s a b -> b -> m () l #= f = modify (l #~ f) -{-# INLINE ( #= ) #-} +{-# INLINE (#=) #-} -- | A version of ('Control.Lens.Setter.%=') that works on 'ALens'. -( #%= ) :: MonadState s m => ALens s s a b -> (a -> b) -> m () +(#%=) :: MonadState s m => ALens s s a b -> (a -> b) -> m () l #%= f = modify (l #%~ f) -{-# INLINE ( #%= ) #-} +{-# INLINE (#%=) #-} -- | A version of ('<%~') that works on 'ALens'. -- @@ -1409,17 +1418,9 @@ {-# INLINE (<#%=) #-} -- | A version of ('%%=') that works on 'ALens'. -( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r -#if MIN_VERSION_mtl(2,1,1) +(#%%=) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r l #%%= f = State.state $ \s -> runPretext (l sell s) f -#else -l #%%= f = do - p <- State.gets (l sell) - let (r, t) = runPretext p f - State.put t - return r -#endif -{-# INLINE ( #%%= ) #-} +{-# INLINE (#%%=) #-} -- | A version of ('Control.Lens.Setter.<.~') that works on 'ALens'. -- 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 @@ -18,6 +18,18 @@ -- * "Control.Lens.Cons" (<|) , (|>) + , (<|~) + , (<|=) + , (<<|~) + , (<<|=) + , (<<<|~) + , (<<<|=) + , (|>~) + , (|>=) + , (<|>~) + , (<|>=) + , (<<|>~) + , (<<|>=) -- * "Control.Lens.Fold" , (^..) , (^?) @@ -62,6 +74,7 @@ , (<<||~) , (<<&&~) , (<<<>~) + , (<<<>:~) , (<%=) , (<+=) , (<-=) @@ -85,9 +98,12 @@ , (<<||=) , (<<&&=) , (<<<>=) + , (<<<>:=) , (<<~) , (<<>~) , (<<>=) + , (<<>:~) + , (<<>:=) , (<%@~) , (<<%@~) , (%%@~) @@ -95,20 +111,20 @@ , (<%@=) , (<<%@=) , (^#) - , ( #~ ) - , ( #%~ ) - , ( #%%~ ) - , ( #= ) - , ( #%= ) + , (#~) + , (#%~) + , (#%%~) + , (#=) + , (#%=) , (<#%~) , (<#%=) - , ( #%%= ) + , (#%%=) , (<#~) , (<#=) -- * "Control.Lens.Plated" , (...) -- * "Control.Lens.Review" - , ( # ) + , (#) -- * "Control.Lens.Setter" , (%~) , (.~) @@ -141,6 +157,8 @@ , (~) , (<>=) + , (<>:~) + , (<>:=) , (.@~) , (.@=) , (%@~) 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,22 +5,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -- gplate1 -#endif +{-# LANGUAGE PolyKinds #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell #endif -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPING_PRAGMA -#else -#define OVERLAPPING_PRAGMA {-# OVERLAPPING #-} -#endif - #include "lens-common.h" ------------------------------------------------------------------------------- @@ -36,7 +26,7 @@ -- used by the \"Scrap Your Boilerplate\" papers, and later inherited by Neil -- Mitchell's \"Uniplate\". -- --- +-- -- -- The combinators in here are designed to be compatible with and subsume the -- @uniplate@ API with the notion of a 'Traversal' replacing @@ -112,18 +102,18 @@ import Control.Monad.Free as Monad import Control.Monad.Free.Church as Church import Control.Monad.Trans.Free as Trans -#if !(MIN_VERSION_free(4,6,0)) -import Control.MonadPlus.Free as MonadPlus -#endif import qualified Language.Haskell.TH as TH import Data.Data import Data.Data.Lens import Data.Tree import GHC.Generics -#ifdef HLINT -{-# ANN module "HLint: ignore Reduce duplication" #-} -#endif +-- $setup +-- >>> :set -XDeriveGeneric -XDeriveDataTypeable +-- >>> import Control.Applicative +-- >>> import Data.Data (Data) +-- >>> import GHC.Generics (Generic) +-- >>> import Control.Lens -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. -- @@ -142,7 +132,7 @@ -- = Val 'Int' -- | Neg Expr -- | Add Expr Expr --- deriving ('Eq','Ord','Show','Read','Data','Typeable') +-- deriving ('Eq','Ord','Show','Read','Data') -- @ -- -- @ @@ -173,7 +163,7 @@ -- data Tree a -- = Bin (Tree a) (Tree a) -- | Tip a --- deriving ('Eq','Ord','Show','Read','Data','Typeable') +-- deriving ('Eq','Ord','Show','Read','Data') -- @ -- -- @ @@ -234,13 +224,6 @@ instance (Traversable f, Traversable m) => Plated (Trans.FreeT f m a) where plate f (Trans.FreeT xs) = Trans.FreeT <$> traverse (traverse f) xs -#if !(MIN_VERSION_free(4,6,0)) -instance Traversable f => Plated (MonadPlus.Free f a) where - plate f (MonadPlus.Free as) = MonadPlus.Free <$> traverse f as - plate f (MonadPlus.Plus as) = MonadPlus.Plus <$> traverse f as - plate _ x = pure x -#endif - instance Traversable f => Plated (Church.F f a) where plate f = fmap Church.toF . plate (fmap Church.fromF . f . Church.toF) . Church.fromF @@ -263,9 +246,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 @@ -405,13 +385,18 @@ -- @ -- 'universeOf' :: 'Fold' a a -> a -> [a] -- @ -universeOf :: Getting [a] a a -> a -> [a] -universeOf l = go where - go a = a : foldMapOf l go a +universeOf :: Getting (Endo [a]) a a -> a -> [a] +universeOf l = \x -> appEndo (universeOf' l x) [] {-# INLINE universeOf #-} +universeOf' :: Getting (Endo [a]) a a -> a -> Endo [a] +universeOf' l = go where + go a = Endo (a :) <> foldMapOf l go a +{-# INLINE universeOf' #-} + + -- | Given a 'Fold' that knows how to find 'Plated' parts of a container retrieve them and all of their descendants, recursively. -universeOn :: Plated a => Getting [a] s a -> s -> [a] +universeOn :: Plated a => Getting (Endo [a]) s a -> s -> [a] universeOn b = universeOnOf b plate {-# INLINE universeOn #-} @@ -421,8 +406,8 @@ -- @ -- 'toListOf' l ≡ 'universeOnOf' l 'ignored' -- @ -universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a] -universeOnOf b = foldMapOf b . universeOf +universeOnOf :: Getting (Endo [a]) s a -> Getting (Endo [a]) a a -> s -> [a] +universeOnOf b = \p x -> appEndo (foldMapOf b (universeOf' p) x) [] {-# INLINE universeOnOf #-} -- | Fold over all transitive descendants of a 'Plated' container, including itself. @@ -436,6 +421,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 #-} @@ -693,7 +680,7 @@ -- -- @ -- 'composOpMonoid' ≡ 'foldMapOf' 'plate' --- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'to' f) +-- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'Control.Lens.Getter.to' f) -- 'composOp' ≡ 'descend' ≡ 'over' 'plate' -- 'composOpM' ≡ 'descendM' ≡ 'mapMOf' 'plate' -- 'composOpM_' ≡ 'descendM_' ≡ 'mapMOf_' 'plate' @@ -729,6 +716,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, Data); data Odd = O Even deriving (Show, Generic, Data) +-- +-- Then 'uniplate', which is based on `Data`, finds +-- all even numbers less or equal than four: +-- +-- >>> import Data.Data.Lens (uniplate) +-- >>> universeOf uniplate (E (O (E (O Z)))) +-- [E (O (E (O Z))),E (O Z),Z] +-- +-- but 'gplate' doesn't see through @Odd@. +-- +-- >>> universeOf gplate (E (O (E (O Z)))) +-- [E (O (E (O Z)))] +-- +-- If using 'Data' is not an option, you can still write the traversal manually. +-- It is sometimes useful to use helper traversals +-- +-- >>> :{ +-- let oddeven :: Traversal' Odd Even +-- oddeven f (O n) = O <$> f n +-- evenplate :: Traversal' Even Even +-- evenplate f Z = pure Z +-- evenplate f (E n) = E <$> oddeven f n +-- :} +-- +-- >>> universeOf evenplate (E (O (E (O Z)))) +-- [E (O (E (O Z))),E (O Z),Z] +-- gplate :: (Generic a, GPlated a (Rep a)) => Traversal' a a gplate f x = GHC.Generics.to <$> gplate' f (GHC.Generics.from x) {-# INLINE gplate #-} @@ -749,7 +771,7 @@ gplate' f (x :*: y) = (:*:) <$> gplate' f x <*> gplate' f y {-# INLINE gplate' #-} -instance OVERLAPPING_PRAGMA GPlated a (K1 i a) where +instance {-# OVERLAPPING #-} GPlated a (K1 i a) where gplate' f (K1 x) = K1 <$> f x {-# INLINE gplate' #-} @@ -765,11 +787,9 @@ gplate' _ v = v `seq` error "GPlated/V1" {-# INLINE gplate' #-} -#if MIN_VERSION_base(4,9,0) instance GPlated a (URec b) where gplate' _ = pure {-# INLINE gplate' #-} -#endif -- | Implement 'plate' operation for a type using its 'Generic1' instance. gplate1 :: (Generic1 f, GPlated1 f (Rep1 f)) => Traversal' (f a) (f a) @@ -816,7 +836,7 @@ {-# INLINE gplate1' #-} -- | match -instance OVERLAPPING_PRAGMA GPlated1 f (Rec1 f) where +instance {-# OVERLAPPING #-} GPlated1 f (Rec1 f) where gplate1' f (Rec1 x) = Rec1 <$> f x {-# INLINE gplate1' #-} @@ -830,9 +850,7 @@ gplate1' f (Comp1 x) = Comp1 <$> traverse (gplate1' f) x {-# INLINE gplate1' #-} -#if MIN_VERSION_base(4,9,0) -- | ignored instance GPlated1 f (URec a) where gplate1' _ = pure {-# INLINE gplate1' #-} -#endif 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 @@ -34,6 +34,7 @@ , below , isn't , matching + , matching' -- * Common Prisms , _Left , _Right @@ -43,34 +44,28 @@ , _Show , only , nearly + , Prefixed(..) + , Suffixed(..) -- * Prismatic profunctors , Choice(..) ) where +import Prelude () + import Control.Applicative +import qualified Control.Lens.Internal.List as List import Control.Lens.Internal.Prism +import Control.Lens.Internal.Prelude import Control.Lens.Lens import Control.Lens.Review import Control.Lens.Type import Control.Monad -import Data.Functor.Identity -import Data.Profunctor +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.List as List import Data.Profunctor.Rep -import Data.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 +import qualified Data.Text as TS +import qualified Data.Text.Lazy as TL -- $setup -- >>> :set -XNoOverloadedStrings @@ -97,23 +92,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 +137,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) @@ -221,6 +208,24 @@ matching k = withPrism k $ \_ seta -> seta {-# INLINE matching #-} +-- | Like 'matching', but also works for combinations of 'Lens' and 'Prism's, +-- and also 'Traversal's. +-- +-- >>> matching' (_2 . _Just) ('x', Just True) +-- Right True +-- +-- >>> matching' (_2 . _Just) ('x', Nothing :: Maybe Int) :: Either (Char, Maybe Bool) Int +-- Left ('x',Nothing) +-- +-- >>> matching' traverse "" :: Either [Int] Char +-- Left [] +-- +-- >>> matching' traverse "xyz" :: Either [Int] Char +-- Right 'x' +matching' :: LensLike (Either a) s t a b -> s -> Either t a +matching' k = either Right Left . k Left +{-# INLINE matching' #-} + ------------------------------------------------------------------------------ -- Common Prisms ------------------------------------------------------------------------------ @@ -379,3 +384,71 @@ [(a,"")] -> Right a _ -> Left s {-# INLINE _Show #-} + +class Prefixed t where + -- | A 'Prism' stripping a prefix from a sequence when used as a 'Traversal', + -- or prepending that prefix when run backwards: + -- + -- >>> "preview" ^? prefixed "pre" + -- Just "view" + -- + -- >>> "review" ^? prefixed "pre" + -- Nothing + -- + -- >>> prefixed "pre" # "amble" + -- "preamble" + prefixed :: t -> Prism' t t + +instance Eq a => Prefixed [a] where + prefixed ps = prism' (ps ++) (List.stripPrefix ps) + {-# INLINE prefixed #-} + +instance Prefixed TS.Text where + prefixed p = prism' (p <>) (TS.stripPrefix p) + {-# INLINE prefixed #-} + +instance Prefixed TL.Text where + prefixed p = prism' (p <>) (TL.stripPrefix p) + {-# INLINE prefixed #-} + +instance Prefixed BS.ByteString where + prefixed p = prism' (p <>) (BS.stripPrefix p) + {-# INLINE prefixed #-} + +instance Prefixed BL.ByteString where + prefixed p = prism' (p <>) (BL.stripPrefix p) + {-# INLINE prefixed #-} + +class Suffixed t where + -- | A 'Prism' stripping a suffix from a sequence when used as a 'Traversal', + -- or appending that suffix when run backwards: + -- + -- >>> "review" ^? suffixed "view" + -- Just "re" + -- + -- >>> "review" ^? suffixed "tire" + -- Nothing + -- + -- >>> suffixed ".o" # "hello" + -- "hello.o" + suffixed :: t -> Prism' t t + +instance Eq a => Suffixed [a] where + suffixed qs = prism' (++ qs) (List.stripSuffix qs) + {-# INLINE suffixed #-} + +instance Suffixed TS.Text where + suffixed qs = prism' (<> qs) (TS.stripSuffix qs) + {-# INLINE suffixed #-} + +instance Suffixed TL.Text where + suffixed qs = prism' (<> qs) (TL.stripSuffix qs) + {-# INLINE suffixed #-} + +instance Suffixed BS.ByteString where + suffixed qs = prism' (<> qs) (BS.stripSuffix qs) + {-# INLINE suffixed #-} + +instance Suffixed BL.ByteString where + suffixed qs = prism' (<> qs) (BL.stripSuffix qs) + {-# INLINE suffixed #-} diff --git a/src/Control/Lens/Profunctor.hs b/src/Control/Lens/Profunctor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Profunctor.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------- +-- | This module provides conversion functions between the optics defined in +-- this library and 'Profunctor'-based optics. +-- +-- The goal of these functions is to provide an interoperability layer between +-- the two styles of optics, and not to reimplement all the library in terms of +-- 'Profunctor' optics. + +module Control.Lens.Profunctor + ( -- * Profunctor optic + OpticP + + -- * Conversion from Van Laarhoven optics + , fromLens + , fromIso + , fromPrism + , fromSetter + , fromTraversal + + -- * Conversion to Van Laarhoven optics + , toLens + , toIso + , toPrism + , toSetter + , toTraversal + ) where + +import Prelude () + +import Control.Lens.Internal.Prelude +import Control.Lens.Type (Optic, LensLike) +import Control.Lens.Internal.Context (Context (..), sell) +import Control.Lens.Internal.Profunctor (WrappedPafb (..)) +import Control.Lens (ASetter, ATraversal, cloneTraversal, Settable) +import Data.Profunctor (Star (..)) +import Data.Profunctor.Mapping (Mapping (..)) +import Data.Profunctor.Traversing (Traversing (..)) + +-- | Profunctor optic. +type OpticP p s t a b = p a b -> p s t + +-------------------------------------------------------------------------------- +-- Conversion from Van Laarhoven optics +-------------------------------------------------------------------------------- + +-- | Converts a 'Control.Lens.Type.Lens' to a 'Profunctor'-based one. +-- +-- @ +-- 'fromLens' :: 'Control.Lens.Type.Lens' s t a b -> LensP s t a b +-- @ +fromLens :: Strong p => LensLike (Context a b) s t a b -> OpticP p s t a b +fromLens l p = + dimap + (\s -> let Context f a = l sell s in (f, a)) + (uncurry id) + (second' p) + +-- | Converts a 'Control.Lens.Type.Iso' to a 'Profunctor'-based one. +-- +-- @ +-- 'fromIso' :: 'Control.Lens.Type.Iso' s t a b -> IsoP s t a b +-- @ +fromIso :: Profunctor p => Optic p Identity s t a b -> OpticP p s t a b +fromIso p pab = rmap runIdentity (p (rmap Identity pab)) + +-- | Converts a 'Control.Lens.Type.Prism' to a 'Profunctor'-based one. +-- +-- @ +-- 'fromPrism' :: 'Control.Lens.Type.Prism' s t a b -> PrismP s t a b +-- @ +fromPrism :: Choice p => Optic p Identity s t a b -> OpticP p s t a b +fromPrism p pab = rmap runIdentity (p (rmap Identity pab)) + +-- | Converts a 'Control.Lens.Type.Setter' to a 'Profunctor'-based one. +-- +-- @ +-- 'fromSetter' :: 'Control.Lens.Type.Setter' s t a b -> SetterP s t a b +-- @ +fromSetter :: Mapping p => ASetter s t a b -> OpticP p s t a b +fromSetter s = roam s' + where + s' f = runIdentity . s (Identity . f) + +-- | Converts a 'Control.Lens.Type.Traversal' to a 'Profunctor'-based one. +-- +-- @ +-- 'fromTraversal' :: 'Control.Lens.Type.Traversal' s t a b -> TraversalP s t a b +-- @ +fromTraversal :: Traversing p => ATraversal s t a b -> OpticP p s t a b +fromTraversal l = wander (cloneTraversal l) + +-------------------------------------------------------------------------------- +-- Conversion to Van Laarhoven optics +-------------------------------------------------------------------------------- + +-- | Obtain a 'Control.Lens.Type.Prism' from a 'Profunctor'-based one. +-- +-- @ +-- 'toPrism' :: PrismP s t a b -> 'Control.Lens.Type.Prism' s t a b +-- @ +toPrism :: (Choice p, Applicative f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b +toPrism p = unwrapPafb . p . WrapPafb + +-- | Obtain a 'Control.Lens.Type.Iso' from a 'Profunctor'-based one. +-- +-- @ +-- 'toIso' :: IsoP s t a b -> 'Control.Lens.Type.Iso' s t a b +-- @ +toIso :: (Profunctor p, Functor f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b +toIso p = unwrapPafb . p . WrapPafb + +-- | Obtain a 'Control.Lens.Type.Lens' from a 'Profunctor'-based one. +-- +-- @ +-- 'toLens' :: LensP s t a b -> 'Control.Lens.Type.Lens' s t a b +-- @ +toLens :: Functor f => OpticP (Star f) s t a b -> LensLike f s t a b +toLens p = runStar . p . Star + +-- | Obtain a 'Control.Lens.Type.Setter' from a 'Profunctor'-based one. +-- +-- @ +-- 'toSetter' :: SetterP s t a b -> 'Control.Lens.Type.Setter' s t a b +-- @ +toSetter :: Settable f => OpticP (Star f) s t a b -> LensLike f s t a b +toSetter p = runStar . p . Star + +-- | Obtain a 'Control.Lens.Type.Traversal' from a 'Profunctor'-based one. +-- +-- @ +-- 'toTraversal' :: TraversalP s t a b -> 'Control.Lens.Type.Traversal' s t a b +-- @ +toTraversal :: Applicative f => OpticP (Star f) s t a b -> LensLike f s t a b +toTraversal p = runStar . p . Star diff --git a/src/Control/Lens/Reified.hs b/src/Control/Lens/Reified.hs --- a/src/Control/Lens/Reified.hs +++ b/src/Control/Lens/Reified.hs @@ -44,12 +44,13 @@ -- $setup -- >>> import Control.Lens +-- >>> import Control.Applicative ------------------------------------------------------------------------------ -- Lens ------------------------------------------------------------------------------ --- | Reify a 'Lens' so it can be stored safely in a container. +-- | Reify a t'Lens' so it can be stored safely in a container. newtype ReifiedLens s t a b = Lens { runLens :: Lens s t a b } -- | @ @@ -61,7 +62,7 @@ -- IndexedLens ------------------------------------------------------------------------------ --- | Reify an 'IndexedLens' so it can be stored safely in a container. +-- | Reify an t'IndexedLens' so it can be stored safely in a container. newtype ReifiedIndexedLens i s t a b = IndexedLens { runIndexedLens :: IndexedLens i s t a b } -- | @ @@ -73,7 +74,7 @@ -- IndexedTraversal ------------------------------------------------------------------------------ --- | Reify an 'IndexedTraversal' so it can be stored safely in a container. +-- | Reify an t'IndexedTraversal' so it can be stored safely in a container. newtype ReifiedIndexedTraversal i s t a b = IndexedTraversal { runIndexedTraversal :: IndexedTraversal i s t a b } -- | @ @@ -85,7 +86,7 @@ -- Traversal ------------------------------------------------------------------------------ --- | A form of 'Traversal' that can be stored monomorphically in a container. +-- | A form of t'Traversal' that can be stored monomorphically in a container. newtype ReifiedTraversal s t a b = Traversal { runTraversal :: Traversal s t a b } -- | @ @@ -97,7 +98,7 @@ -- Getter ------------------------------------------------------------------------------ --- | Reify a 'Getter' so it can be stored safely in a container. +-- | Reify a t'Getter' so it can be stored safely in a container. -- -- This can also be useful when combining getters in novel ways, as -- 'ReifiedGetter' is isomorphic to '(->)' and provides similar instances. @@ -248,7 +249,7 @@ -- IndexedGetter ------------------------------------------------------------------------------ --- | Reify an 'IndexedGetter' so it can be stored safely in a container. +-- | Reify an t'IndexedGetter' so it can be stored safely in a container. newtype ReifiedIndexedGetter i s a = IndexedGetter { runIndexedGetter :: IndexedGetter i s a } instance Profunctor (ReifiedIndexedGetter i) where @@ -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 @@ -288,7 +289,7 @@ -- Fold ------------------------------------------------------------------------------ --- | Reify a 'Fold' so it can be stored safely in a container. +-- | Reify a t'Fold' so it can be stored safely in a container. -- -- This can also be useful for creatively combining folds as -- @'ReifiedFold' s@ is isomorphic to @ReaderT s []@ and provides similar @@ -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 = [] @@ -415,8 +416,10 @@ instance Monoid (ReifiedFold s a) where mempty = Fold ignored {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend = (<|>) {-# INLINE mappend #-} +#endif instance Alt (ReifiedFold s) where () = (<|>) @@ -439,8 +442,10 @@ instance Monoid (ReifiedIndexedFold i s a) where mempty = IndexedFold ignored {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend = () {-# INLINE mappend #-} +#endif instance Alt (ReifiedIndexedFold i s) where IndexedFold ma IndexedFold mb = IndexedFold $ @@ -485,7 +490,7 @@ -- Setter ------------------------------------------------------------------------------ --- | Reify a 'Setter' so it can be stored safely in a container. +-- | Reify a t'Setter' so it can be stored safely in a container. newtype ReifiedSetter s t a b = Setter { runSetter :: Setter s t a b } -- | @ @@ -497,7 +502,7 @@ -- IndexedSetter ------------------------------------------------------------------------------ --- | Reify an 'IndexedSetter' so it can be stored safely in a container. +-- | Reify an t'IndexedSetter' so it can be stored safely in a container. newtype ReifiedIndexedSetter i s t a b = IndexedSetter { runIndexedSetter :: IndexedSetter i s t a b } @@ -510,7 +515,7 @@ -- Iso ------------------------------------------------------------------------------ --- | Reify an 'Iso' so it can be stored safely in a container. +-- | Reify an t'Iso' so it can be stored safely in a container. newtype ReifiedIso s t a b = Iso { runIso :: Iso s t a b } -- | @ @@ -522,7 +527,7 @@ -- Prism ------------------------------------------------------------------------------ --- | Reify a 'Prism' so it can be stored safely in a container. +-- | Reify a t'Prism' so it can be stored safely in a container. newtype ReifiedPrism s t a b = Prism { runPrism :: Prism s t a b } -- | @ diff --git a/src/Control/Lens/Review.hs b/src/Control/Lens/Review.hs --- a/src/Control/Lens/Review.hs +++ b/src/Control/Lens/Review.hs @@ -2,9 +2,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE Trustworthy #-} -#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-redundant-constraints -Wno-trustworthy-safe #-} -#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Review @@ -27,10 +25,11 @@ , re , review, reviews , reuse, reuses - , ( # ) + , (#) , Bifunctor(bimap) , retagged , Reviewable + , reviewing ) where import Control.Monad.Reader as Reader @@ -48,7 +47,9 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens +-- >>> import Control.Monad.State -- >>> import Numeric.Lens +-- >>> import Data.Semigroup (Semigroup (..)) -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False @@ -164,9 +165,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 +241,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 @@ -49,11 +49,11 @@ , over , set , (.~), (%~) - , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (~), (<>:~), (&&~), (<.~), (?~), (=), (&&=), (<.=), (?=), (=), (<>:=), (&&=), (<.=), (?=), (>> 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 @@ -110,8 +105,8 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> :set -XNoOverloadedStrings -infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, =, ||=, %=, <.=, ?=, ~, <>:~, ||~, %~, <.~, ?~, =, <>:=, ||=, %=, <.=, ?=, Setter s t a b -cloneSetter l afb = taintedDot $ runIdentity #. l (Identity #. untaintedDot afb) +cloneSetter l afb = taintedDot $ coerce l (untaintedDot afb) {-# INLINE cloneSetter #-} -- | Build an 'IndexPreservingSetter' from any 'Setter'. @@ -352,7 +347,7 @@ -- 'over' :: 'ASetter' s t a b -> (a -> b) -> s -> t -- @ over :: ASetter s t a b -> (a -> b) -> s -> t -over l f = runIdentity #. l (Identity #. f) +over = coerce {-# INLINE over #-} -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' @@ -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" = a = State.modify (l <>~ a) {-# INLINE (<>=) #-} +-- | Modify the target of a 'Semigroup' value by using @('<>')@. +-- However, unlike '<>~', it is prepend to the head side. +-- +-- >>> ["world"] & id <>:~ ["hello"] +-- ["hello","world"] +-- +-- >>> (["world"], ["lens"]) & _1 <>:~ ["hello"] +-- (["hello","world"],["lens"]) +(<>:~) :: Semigroup b => ASetter s t b b -> b -> s -> t +l <>:~ n = over l (n <>) +{-# INLINE (<>:~) #-} + +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('<>')@. +-- However, unlike '<>=', it is prepend to the head side. +(<>:=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m () +l <>:= a = State.modify (l <>:~ a) +{-# INLINE (<>:=) #-} + ----------------------------------------------------------------------------- -- Writer Operations ----------------------------------------------------------------------------- @@ -1180,7 +1193,7 @@ -- 'iover' :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ iover :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t -iover l f = runIdentity #. l (Identity #. Indexed f) +iover = coerce {-# INLINE iover #-} -- | Set with index. Equivalent to 'iover' with the current value ignored. diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -28,6 +28,7 @@ , makeClassy, makeClassyFor, makeClassy_ , makeFields , makeFieldsNoPrefix + , makeFieldsId -- ** Prisms , makePrisms , makeClassyPrisms @@ -58,6 +59,7 @@ , classUnderscoreNoPrefixFields , underscoreFields , abbreviatedFields + , classIdFields -- ** LensRules configuration accessors , lensField , FieldNamer @@ -69,6 +71,7 @@ , generateSignatures , generateUpdateableOptics , generateLazyPatterns + , generateRecordSyntax -- ** FieldNamers , underscoreNoPrefixNamer , lookingupNamer @@ -77,13 +80,11 @@ , classUnderscoreNoPrefixNamer , underscoreNamer , abbreviatedNamer + , classIdNamer ) where import Prelude () -#if !(MIN_VERSION_template_haskell(2,7,0)) -import Control.Monad (ap) -#endif import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.Trans.Writer @@ -91,7 +92,6 @@ import Control.Lens.Getter import Control.Lens.Lens import Control.Lens.Setter -import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Internal.Prelude as Prelude import Control.Lens.Internal.TH @@ -107,19 +107,12 @@ import Data.Maybe (maybeToList) import qualified Data.Set as Set import Data.Set (Set) -import Data.Set.Lens import Data.Traversable hiding (mapM) -import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lens +import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax hiding (lift) -#ifdef HLINT -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Use fewer imports" #-} -{-# ANN module "HLint: ignore Use foldl" #-} -#endif - -- | Generate "simple" optics even when type-changing optics are possible. -- (e.g. 'Lens'' instead of 'Lens') simpleLenses :: Lens' LensRules Bool @@ -171,6 +164,10 @@ generateLazyPatterns f r = fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r)) +generateRecordSyntax :: Lens' LensRules Bool +generateRecordSyntax f r = + fmap (\x -> r {_recordSyntax = x}) (f (_recordSyntax r)) + -- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the -- 'lensClass' rule matches. createClass :: Lens' LensRules Bool @@ -196,6 +193,7 @@ , _allowIsos = True , _allowUpdates = True , _lazyPatterns = False + , _recordSyntax = False , _classyLenses = const Nothing , _fieldToDef = underscoreNoPrefixNamer } @@ -237,6 +235,7 @@ , _allowIsos = False -- generating Isos would hinder "subtyping" , _allowUpdates = True , _lazyPatterns = False + , _recordSyntax = False , _classyLenses = \n -> case nameBase n of x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs)) @@ -451,7 +450,9 @@ -- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype. declareWrapped :: DecsQ -> DecsQ declareWrapped = declareWith $ \dec -> do - maybeDecs <- liftDeclare (makeWrappedForDec dec) + maybeDecs <- liftDeclare $ do + inf <- normalizeDec dec + makeWrappedForDatatypeInfo inf forM_ maybeDecs emit return dec @@ -471,19 +472,6 @@ -- Internal TH Implementation ----------------------------------------------------------------------------- --- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to --- @DataInstD@s. -deNewtype :: Dec -> Dec -#if MIN_VERSION_template_haskell(2,11,0) -deNewtype (NewtypeD ctx tyName args kind c d) = DataD ctx tyName args kind [c] d -deNewtype (NewtypeInstD ctx tyName args kind c d) = DataInstD ctx tyName args kind [c] d -#else -deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d -deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d -#endif -deNewtype d = d - - -- | Given a set of names, build a map from those names to a set of fresh names -- based on them. freshMap :: Set Name -> Q (Map Name Name) @@ -494,111 +482,42 @@ apps = Prelude.foldl AppT -makeDataDecl :: Dec -> Maybe DataDecl -makeDataDecl dec = case deNewtype dec of - DataD ctx tyName args -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> Just DataDecl - { dataContext = ctx - , tyConName = Just tyName - , dataParameters = args - , fullType = apps $ ConT tyName - , constructors = cons - } -#if MIN_VERSION_template_haskell(2,15,0) - DataInstD ctx _ fnArgs _ cons _ -#else - DataInstD ctx familyName args -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -#endif - -> Just DataDecl - { dataContext = ctx - , tyConName = Nothing - , dataParameters = map PlainTV vars - , fullType = \tys -> apps (ConT familyName) $ - substType (Map.fromList $ zip vars tys) args - , constructors = cons - } - where - -- The list of "type parameters" to a data family instance is not - -- explicitly specified in the source. Here we define it to be - -- the set of distinct type variables that appear in the LHS. e.g. - -- - -- data instance F a Int (Maybe (a, b)) = G - -- - -- has 2 type parameters: a and b. - vars = toList $ setOf typeVars args - -#if MIN_VERSION_template_haskell(2,15,0) - (familyName, args) = - case unfoldType fnArgs of - (ConT familyName', args') -> (familyName', args') - (_, _) -> error $ "Illegal data instance LHS: " ++ pprint fnArgs -#endif - _ -> Nothing - --- | A data, newtype, data instance or newtype instance declaration. -data DataDecl = DataDecl - { dataContext :: Cxt -- ^ Datatype context. - , tyConName :: Maybe Name - -- ^ Type constructor name, or Nothing for a data family instance. - , dataParameters :: [TyVarBndr] -- ^ List of type parameters - , fullType :: [Type] -> Type - -- ^ Create a concrete record type given a substitution to - -- 'detaParameters'. - , constructors :: [Con] -- ^ Constructors - -- , derivings :: [Name] -- currently not needed - } - - - -- | Build 'Wrapped' instance for a given newtype makeWrapped :: Name -> DecsQ makeWrapped nm = do - inf <- reify nm - case inf of - TyConI decl -> do - maybeDecs <- makeWrappedForDec decl - maybe (fail "makeWrapped: Unsupported data type") return maybeDecs - _ -> fail "makeWrapped: Expected the name of a newtype or datatype" + inf <- reifyDatatype nm + maybeDecs <- makeWrappedForDatatypeInfo inf + maybe (fail "makeWrapped: Unsupported data type") return maybeDecs -makeWrappedForDec :: Dec -> Q (Maybe [Dec]) -makeWrappedForDec decl = case makeDataDecl decl of - Just dataDecl | [con] <- constructors dataDecl - , [field] <- toListOf (conFields._2) con - -> do wrapped <- makeWrappedInstance dataDecl con field - rewrapped <- makeRewrappedInstance dataDecl - return (Just [rewrapped, wrapped]) - _ -> return Nothing +makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec]) +makeWrappedForDatatypeInfo dataInfo@(DatatypeInfo{datatypeCons = cons}) + | [conInfo@(ConstructorInfo{constructorFields = fields})] <- cons + , [field] <- fields + = do wrapped <- makeWrappedInstance dataInfo conInfo field + rewrapped <- makeRewrappedInstance dataInfo + return (Just [rewrapped, wrapped]) -makeRewrappedInstance :: DataDecl -> DecQ -makeRewrappedInstance dataDecl = do + | otherwise = return Nothing +makeRewrappedInstance :: DatatypeInfo -> DecQ +makeRewrappedInstance dataInfo = do + t <- varT <$> newName "t" - let typeArgs = map (view name) (dataParameters dataDecl) + let typeArgs = map (view name) (datatypeVars dataInfo) typeArgs' <- do m <- freshMap (Set.fromList typeArgs) return (substTypeVars m typeArgs) -- Con a b c... - let appliedType = return (fullType dataDecl (map VarT typeArgs)) + let appliedType = return (applyDatatypeToArgs dataInfo (map VarT typeArgs)) -- Con a' b' c'... - appliedType' = return (fullType dataDecl (map VarT typeArgs')) + appliedType' = return (applyDatatypeToArgs dataInfo (map VarT typeArgs')) -- Con a' b' c'... ~ t -#if MIN_VERSION_template_haskell(2,10,0) eq = AppT. AppT EqualityT <$> appliedType' <*> t -#else - eq = equalP appliedType' t -#endif -- Rewrapped (Con a b c...) t klass = conT rewrappedTypeName `appsT` [appliedType, t] @@ -606,14 +525,14 @@ -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t instanceD (cxt [eq]) klass [] -makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ -makeWrappedInstance dataDecl con fieldType = do +makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ +makeWrappedInstance dataInfo conInfo fieldType = do - let conName = view name con - let typeArgs = toListOf typeVars (dataParameters dataDecl) + let conName = constructorName conInfo + let typeArgs = toListOf typeVars (datatypeVars dataInfo) -- Con a b c... - let appliedType = fullType dataDecl (map VarT typeArgs) + let appliedType = applyDatatypeToArgs dataInfo (map VarT typeArgs) -- type Unwrapped (Con a b c...) = $fieldType let unwrappedATF = tySynInstDCompat unwrappedTypeName Nothing @@ -633,12 +552,22 @@ -- _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 +-- | Apply the 'datatypeName' of a 'DatatypeInfo' to some argument 'Type's, +-- which are used to instantiate its 'datatypeVars'. +applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type +applyDatatypeToArgs di@(DatatypeInfo { datatypeName = nm + , datatypeVars = vars + , datatypeInstTypes = instTypes + }) args = + apps (ConT nm) $ + -- Drop kind signatures if possible to reduce the likelihood of needing to + -- enable KindSignatures. The likelihood is already quite small, however. + -- This function is only used for the benefit of {make,declare}Wrapped, and + -- one needs to enable TypeFamilies in order for the generated code to + -- typecheck. Since TypeFamilies implies KindSignatures, dropping kind + -- signatures is probably not required, but better to be safe then sorry. + dropSigsIfNonDataFam di $ + applySubstitution (Map.fromList (zip (map tvName vars) args)) instTypes overHead :: (a -> a) -> [a] -> [a] overHead _ [] = [] @@ -708,6 +637,19 @@ methodName = fieldUnprefixed return (MethodName (mkName className) (mkName methodName)) +-- | Field rules for fields whose names are to be used verbatim, with no +-- prefixes, no underscores, no transformations of any kind. +classIdFields :: LensRules +classIdFields = + defaultFieldRules & lensField .~ classIdNamer + +-- | A 'FieldNamer' for 'classIdFields'. +classIdNamer :: FieldNamer +classIdNamer _ _ field = [MethodName (mkName className) (mkName fieldName)] + where + fieldName = nameBase field + className = "Has" ++ overHead toUpper fieldName + -- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @ -- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. -- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created. @@ -818,6 +760,42 @@ makeFieldsNoPrefix :: Name -> DecsQ makeFieldsNoPrefix = makeFieldOptics classUnderscoreNoPrefixFields +-- | Generate overloaded field accessors, using exactly the same names as the +-- underlying fields. Intended for use with the @NoFieldSelectors@ and +-- @DuplicateRecordFields@ language extensions. +-- +-- As an example: +-- +-- @ +-- data Foo a = Foo { x :: 'Int', y :: a } +-- newtype Bar = Bar { x :: 'Char' } +-- makeFieldsId ''Foo +-- makeFieldsId ''Bar +-- @ +-- +-- will create classes +-- +-- @ +-- class HasX s a | s -> a where +-- x :: Lens' s a +-- class HasY s a | s -> a where +-- y :: Lens' s a +-- @ +-- +-- together with instances +-- +-- @ +-- instance HasX (Foo a) Int +-- instance HasY (Foo a) a where +-- instance HasX Bar Char where +-- @ +-- +-- @ +-- makeFieldsId = 'makeLensesWith' 'classIdFields' +-- @ +makeFieldsId :: Name -> DecsQ +makeFieldsId = makeFieldOptics classIdFields + defaultFieldRules :: LensRules defaultFieldRules = LensRules { _simpleLenses = True @@ -826,6 +804,7 @@ , _allowIsos = False -- generating Isos would hinder field class reuse , _allowUpdates = True , _lazyPatterns = False + , _recordSyntax = False , _classyLenses = const Nothing , _fieldToDef = camelCaseNamer } @@ -857,7 +836,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 @@ -867,16 +846,11 @@ -- Recurse into instance declarations because they main contain -- associated data family instances. -#if MIN_VERSION_template_haskell(2,11,0) InstanceD moverlap ctx inst body -> InstanceD moverlap ctx inst <$> traverse go body -#else - InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body -#endif _ -> pure dec stripFields :: Dec -> Dec stripFields dec = case dec of -#if MIN_VERSION_template_haskell(2,11,0) DataD ctx tyName tyArgs kind cons derivings -> DataD ctx tyName tyArgs kind (map deRecord cons) derivings NewtypeD ctx tyName tyArgs kind con derivings -> @@ -885,16 +859,6 @@ DataInstD ctx tyName tyArgs kind (map deRecord cons) derivings NewtypeInstD ctx tyName tyArgs kind con derivings -> NewtypeInstD ctx tyName tyArgs kind (deRecord con) derivings -#else - DataD ctx tyName tyArgs cons derivings -> - DataD ctx tyName tyArgs (map deRecord cons) derivings - NewtypeD ctx tyName tyArgs con derivings -> - NewtypeD ctx tyName tyArgs (deRecord con) derivings - DataInstD ctx tyName tyArgs cons derivings -> - DataInstD ctx tyName tyArgs (map deRecord cons) derivings - NewtypeInstD ctx tyName tyArgs con derivings -> - NewtypeInstD ctx tyName tyArgs (deRecord con) derivings -#endif _ -> dec deRecord :: Con -> Con @@ -902,14 +866,8 @@ deRecord con@InfixC{} = con deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields) -#if MIN_VERSION_template_haskell(2,11,0) deRecord con@GadtC{} = con deRecord (RecGadtC ns fields retTy) = GadtC ns (map dropFieldName fields) retTy -#endif -#if MIN_VERSION_template_haskell(2,11,0) -dropFieldName :: VarBangType -> BangType -#else -dropFieldName :: VarStrictType -> StrictType -#endif +dropFieldName :: VarBangType -> BangType dropFieldName (_, str, typ) = (str, typ) diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs --- a/src/Control/Lens/Traversal.hs +++ b/src/Control/Lens/Traversal.hs @@ -55,6 +55,7 @@ , Traversing1, Traversing1' -- * Traversing and Lensing + , traversal , traverseOf, forOf, sequenceAOf , mapMOf, forMOf, sequenceOf , transposeOf @@ -161,21 +162,26 @@ import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable import Data.Tuple (swap) -import GHC.Magic (inline) +import GHC.Exts (inline) -- $setup -- >>> :set -XNoOverloadedStrings -XFlexibleContexts -- >>> import Data.Char (toUpper) +-- >>> import Control.Applicative -- >>> import Control.Lens +-- >>> import Control.Lens.Internal.Context -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate,try,ErrorCall(..)) -- >>> import Data.Maybe (fromMaybe) +-- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Debug.SimpleReflect.Vars -- >>> import Data.Void -- >>> import Data.List (sort) -- >>> import System.Timeout (timeout) -- >>> import qualified Data.List.NonEmpty as NonEmpty -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force +-- >>> let firstAndThird :: Traversal (a, x, a) (b, x, b) a b; firstAndThird = traversal go where { go :: Applicative f => (a -> f b) -> (a, x, a) -> f (b, x, b); go focus (a, x, a') = liftA3 (,,) (focus a) (pure x) (focus a') } +-- >>> let selectNested :: Traversal (x, [a]) (x, [b]) a b; selectNested = traversal go where { go :: Applicative f => (a -> f b) -> (x, [a]) -> f (x, [b]); go focus (x, as) = liftA2 (,) (pure x) (traverse focus as) } ------------------------------------------------------------------------------ -- Traversals @@ -242,6 +248,70 @@ -- Traversal Combinators -------------------------- +-- | Build a 'Traversal' by providing a function which specifies the elements you wish to +-- focus. +-- +-- The caller provides a function of type: +-- +-- @ +-- Applicative f => (a -> f b) -> s -> f t +-- @ +-- +-- Which is a higher order function which accepts a "focusing function" and applies +-- it to all desired focuses within @s@, then constructs a @t@ using the Applicative +-- instance of @f@. +-- +-- Only elements which are "focused" using the focusing function will be targeted by the +-- resulting traversal. +-- +-- For example, we can explicitly write a traversal which targets the first and third elements +-- of a tuple like this: +-- +-- @ +-- firstAndThird :: Traversal (a, x, a) (b, x, b) a b +-- firstAndThird = traversal go +-- where +-- go :: Applicative f => (a -> f b) -> (a, x, a) -> f (b, x, b) +-- go focus (a, x, a') = liftA3 (,,) (focus a) (pure x) (focus a') +-- @ +-- +-- >>> (1,"two",3) & firstAndThird *~ 10 +-- (10,"two",30) +-- +-- >>> over firstAndThird length ("one",2,"three") +-- (3,2,5) +-- +-- We can re-use existing 'Traversal's when writing new ones by passing our focusing function +-- along to them. This example re-uses 'traverse' to focus all elements in a list which is +-- embedded in a tuple. This traversal could also be written simply as @_2 . traverse@. +-- +-- @ +-- selectNested :: Traversal (x, [a]) (x, [b]) a b +-- selectNested = traversal go +-- where +-- go :: Applicative f => (a -> f b) -> (x, [a]) -> f (x, [b]) +-- go focus (x, as) = liftA2 (,) (pure x) (traverse focus as) +-- @ +-- +-- >>> selectNested .~ "hello" $ (1,[2,3,4,5]) +-- (1,["hello","hello","hello","hello"]) +-- +-- >>> (1,[2,3,4,5]) & selectNested *~ 3 +-- (1,[6,9,12,15]) +-- +-- Note that the 'traversal' function actually just returns the same function you pass to +-- it. The function it accepts is in fact a valid traversal all on its own! The use of +-- 'traversal' does nothing except verify that the function it is passed matches the signature +-- of a valid traversal. One could remove the @traversal@ combinator from either of the last +-- two examples and use the definition of @go@ directly with no change in behaviour. +-- +-- This function exists for consistency with the 'lens', 'prism' and 'iso' constructors +-- as well as to serve as a touchpoint for beginners who wish to construct their own +-- traversals but are uncertain how to do so. +traversal :: ((a -> f b) -> s -> f t) -> LensLike f s t a b +traversal = id +{-# INLINE traversal #-} + -- | Map each element of a structure targeted by a 'Lens' or 'Traversal', -- evaluate these actions from left to right, and collect the results. -- @@ -342,7 +412,7 @@ -- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t -- @ mapMOf :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t -mapMOf l cmd = unwrapMonad #. l (WrapMonad #. cmd) +mapMOf = coerce {-# INLINE mapMOf #-} -- | 'forMOf' is a flipped version of 'mapMOf', consistent with the definition of 'forM'. @@ -734,7 +804,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 @@ -1050,7 +1120,7 @@ -- 'imapMOf' :: 'Bind' m => 'IndexedTraversal1' i s t a b -> (i -> a -> m b) -> s -> m t -- @ imapMOf :: Over (Indexed i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t -imapMOf l cmd = unwrapMonad #. l (WrapMonad #. Indexed cmd) +imapMOf = coerce {-# INLINE imapMOf #-} -- | Map each element of a structure targeted by a 'Lens' to a monadic action, @@ -1161,11 +1231,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 +1248,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 +1290,7 @@ -- 'element' ≡ 'elementOf' 'traverse' -- @ element :: Traversable t => Int -> IndexedTraversal' Int (t a) a -element = elementOf traverse +element i = elementOf traverse i {-# INLINE element #-} -- | Traverse (or fold) selected elements of a 'Traversal' (or 'Fold') where their ordinal positions match a predicate. @@ -1250,7 +1312,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,8 @@ import Control.Lens.Lens import Control.Lens.Internal.Prelude import Data.Functor.Product (Product (..)) +import Data.Kind +import Data.Strict (Pair (..)) import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..), U1 (..)) @@ -109,6 +109,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 +219,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 -- @ @@ -1158,7 +1166,7 @@ ix n f = fmap to . gix n f . from {-# INLINE ix #-} -type family GSize (f :: * -> *) +type family GSize (f :: Type -> Type) type instance GSize U1 = Z type instance GSize (K1 i c) = S Z type instance GSize (M1 i c f) = GSize f @@ -1182,14 +1190,12 @@ gix = gix' (Proxy :: Proxy p) {-# INLINE gix #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 -- $gixed-fundeps -- >>> :set -XDeriveGeneric -XFlexibleInstances -XMultiParamTypeClasses -- >>> import GHC.Generics (Generic) -- >>> data Product a b = a :* b deriving Generic -- >>> instance Field1 (Product a b) (Product a' b) a a' -- >>> instance Field2 (Product a b) (Product a b') b b' -#endif class (p ~ GT (GSize s) n, p ~ GT (GSize t) n) 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,14 +5,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE Trustworthy #-} + +#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 800 +#else {-# LANGUAGE TypeInType #-} #endif -{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Type @@ -70,9 +69,7 @@ import Control.Lens.Internal.Indexed import Data.Bifunctor import Data.Functor.Apply -#if __GLASGOW_HASKELL__ >= 800 import Data.Kind -#endif -- $setup -- >>> :set -XNoOverloadedStrings @@ -209,6 +206,11 @@ -- @ type Traversal' s a = Traversal s s a a +-- | A 'Traversal' which targets at least one element. +-- +-- Note that since 'Apply' is not a superclass of 'Applicative', a 'Traversal1' +-- cannot always be used in place of a 'Traversal'. In such circumstances +-- 'Control.Lens.Traversal.cloneTraversal' will convert a 'Traversal1' into a 'Traversal'. type Traversal1 s t a b = forall f. Apply f => (a -> f b) -> s -> f t type Traversal1' s a = Traversal1 s s a a @@ -233,7 +235,7 @@ type IndexedTraversal1 i s t a b = forall p f. (Indexable i p, Apply f) => p a (f b) -> s -> f t type IndexedTraversal1' i s a = IndexedTraversal1 i s s a a --- | An 'IndexPreservingLens' leaves any index it is composed with alone. +-- | An 'IndexPreservingTraversal' leaves any index it is composed with alone. type IndexPreservingTraversal s t a b = forall p f. (Conjoined p, Applicative f) => p a (f b) -> p s (f t) -- | @ @@ -462,13 +464,7 @@ -- | A witness that @(a ~ s, b ~ t)@. -- -- 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 :: * -> *) . -#endif p a (f b) -> p s (f t) -- | A 'Simple' 'Equality'. 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 -Wno-warnings-deprecations #-} + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Unsound @@ -21,7 +18,7 @@ -- Portability : Rank2Types -- -- One commonly asked question is: can we combine two lenses, --- @`Lens'` a b@ and @`Lens'` a c@ into @`Lens'` a (b, c)@. +-- @'Lens'' a b@ and @'Lens'' a c@ into @'Lens'' a (b, c)@. -- This is fair thing to ask, but such operation is unsound in general. -- See `lensProduct`. -- @@ -37,8 +34,12 @@ 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 +-- Result is only a valid t'Lens' if the input lenses project disjoint parts of -- the structure @s@. Otherwise "you get what you put in" law -- -- @ @@ -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,22 +7,18 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} +#if !(MIN_VERSION_base(4,16,0)) || !MIN_VERSION_transformers(0,6,0) +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} #endif -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - #include "lens-common.h" ----------------------------------------------------------------------------- @@ -34,7 +30,7 @@ -- Stability : experimental -- Portability : Rank2, MPTCs, fundeps -- --- The 'Wrapped' class provides similar functionality as @Control.Newtype@, +-- The t'Wrapped' class provides similar functionality as @Control.Newtype@, -- from the @newtype@ package, but in a more convenient and efficient form. -- -- There are a few functions from @newtype@ that are not provided here, because @@ -69,11 +65,9 @@ -- * Operations , op , ala, alaf -#if __GLASGOW_HASKELL__ >= 710 -- * Pattern Synonyms , pattern Wrapped , pattern Unwrapped -#endif -- * Generics , _GWrapped' ) where @@ -93,17 +87,13 @@ import Control.Lens.Getter import Control.Lens.Internal.CTypes import Control.Lens.Iso -#if __GLASGOW_HASKELL__ >= 710 import Control.Lens.Review -#endif import Control.Monad.Catch.Pure import Control.Monad.Trans.Cont -import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Free import Control.Monad.Trans.Identity import Control.Monad.Trans.Iter -import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.RWS.Lazy as Lazy @@ -112,6 +102,10 @@ import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict +#if !MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif import Data.Bifunctor.Biff import Data.Bifunctor.Clown import Data.Bifunctor.Fix @@ -129,12 +123,19 @@ 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.Kind +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Monoid as Monoid import Data.Monoid import qualified Data.Profunctor as Profunctor import Data.Profunctor hiding (WrappedArrow(..)) @@ -143,41 +144,38 @@ 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 +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as VectorStrict +#endif +import qualified Data.Vector.Primitive as Prim +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Unboxed as Unboxed +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Storable as Storable import Foreign.C.Error import Foreign.C.Types +import Foreign.Storable (Storable) import qualified GHC.Generics as Generic import GHC.Generics hiding (from, to) import System.Posix.Types - -#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 +-- | t'Wrapped' provides isomorphisms to wrap and unwrap newtypes or -- data types with one constructor. class Wrapped s where - type Unwrapped s :: * + type Unwrapped s :: Type type Unwrapped s = GUnwrapped (Rep s) -- | An isomorphism between @s@ and @a@. @@ -199,21 +197,19 @@ reviewer x = M1 (M1 (M1 (K1 x))) {-# INLINE _GWrapped' #-} -type family GUnwrapped (rep :: * -> *) :: * +type family GUnwrapped (rep :: Type -> Type) :: Type type instance GUnwrapped (D1 d (C1 c (S1 s (Rec0 a)))) = a -#if __GLASGOW_HASKELL__ >= 710 - +pattern Wrapped :: Rewrapped s s => Unwrapped s -> s pattern Wrapped a <- (view _Wrapped -> a) where Wrapped a = review _Wrapped a +pattern Unwrapped :: Rewrapped t t => t -> Unwrapped t pattern Unwrapped a <- (view _Unwrapped -> a) where Unwrapped a = review _Unwrapped a -#endif - -- This can be used to help inference between the wrappers -class Wrapped s => Rewrapped (s :: *) (t :: *) +class Wrapped s => Rewrapped (s :: Type) (t :: Type) class (Rewrapped s t, Rewrapped t s) => Rewrapping s t instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t @@ -325,13 +321,11 @@ _Wrapped' = iso getLast Last {-# INLINE _Wrapped' #-} -#if MIN_VERSION_base(4,8,0) instance (t ~ Monoid.Alt g b) => Rewrapped (Monoid.Alt f a) t instance Wrapped (Monoid.Alt f a) where type Unwrapped (Monoid.Alt f a) = f a _Wrapped' = iso Monoid.getAlt Monoid.Alt {-# INLINE _Wrapped' #-} -#endif #if MIN_VERSION_base(4,12,0) instance (t ~ Monoid.Ap g b) => Rewrapped (Monoid.Ap f a) t @@ -385,12 +379,6 @@ type Unwrapped (ContT r m a) = (a -> m r) -> m r _Wrapped' = iso runContT ContT -instance (t ~ ErrorT e' m' a') => Rewrapped (ErrorT e m a) t -instance Wrapped (ErrorT e m a) where - type Unwrapped (ErrorT e m a) = m (Either e a) - _Wrapped' = iso runErrorT ErrorT - {-# INLINE _Wrapped' #-} - instance (t ~ ExceptT e' m' a') => Rewrapped (ExceptT e m a) t instance Wrapped (ExceptT e m a) where type Unwrapped (ExceptT e m a) = m (Either e a) @@ -409,12 +397,6 @@ _Wrapped' = iso runIdentityT IdentityT {-# INLINE _Wrapped' #-} -instance (t ~ ListT n b) => Rewrapped (ListT m a) t -instance Wrapped (ListT m a) where - type Unwrapped (ListT m a) = m [a] - _Wrapped' = iso runListT ListT - {-# INLINE _Wrapped' #-} - instance (t ~ MaybeT n b) => Rewrapped (MaybeT m a) t instance Wrapped (MaybeT m a) where type Unwrapped (MaybeT m a) = m (Maybe a) @@ -469,6 +451,20 @@ _Wrapped' = iso Strict.runWriterT Strict.WriterT {-# INLINE _Wrapped' #-} +#if !MIN_VERSION_transformers(0,6,0) +instance (t ~ ErrorT e' m' a') => Rewrapped (ErrorT e m a) t +instance Wrapped (ErrorT e m a) where + type Unwrapped (ErrorT e m a) = m (Either e a) + _Wrapped' = iso runErrorT ErrorT + {-# INLINE _Wrapped' #-} + +instance (t ~ ListT n b) => Rewrapped (ListT m a) t +instance Wrapped (ListT m a) where + type Unwrapped (ListT m a) = m [a] + _Wrapped' = iso runListT ListT + {-# INLINE _Wrapped' #-} +#endif + -- * bifunctors instance (t ~ Biff p' f' g' a' b') => Rewrapped (Biff p f g a b) t @@ -575,14 +571,14 @@ -- * unordered-containers --- | Use @'wrapping' 'HashMap.fromList'@. Unwrapping returns some permutation of the list. +-- | Use @'_Wrapping' 'HashMap.fromList'@. Unwrapping returns some permutation of the list. instance (t ~ HashMap k' a', Hashable k, Eq k) => Rewrapped (HashMap k a) t instance (Hashable k, Eq k) => Wrapped (HashMap k a) where type Unwrapped (HashMap k a) = [(k, a)] _Wrapped' = iso HashMap.toList HashMap.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'HashSet.fromList'@. Unwrapping returns some permutation of the list. +-- | Use @'_Wrapping' 'HashSet.fromList'@. Unwrapping returns some permutation of the list. instance (t ~ HashSet a', Hashable a, Eq a) => Rewrapped (HashSet a) t instance (Hashable a, Eq a) => Wrapped (HashSet a) where type Unwrapped (HashSet a) = [a] @@ -591,28 +587,28 @@ -- * containers --- | Use @'wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list. +-- | Use @'_Wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ IntMap a') => Rewrapped (IntMap a) t instance Wrapped (IntMap a) where type Unwrapped (IntMap a) = [(Int, a)] _Wrapped' = iso IntMap.toAscList IntMap.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list. +-- | Use @'_Wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ IntSet) => Rewrapped IntSet t instance Wrapped IntSet where type Unwrapped IntSet = [Int] _Wrapped' = iso IntSet.toAscList IntSet.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list. +-- | Use @'_Wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ Map k' a', Ord k) => Rewrapped (Map k a) t instance Ord k => Wrapped (Map k a) where type Unwrapped (Map k a) = [(k, a)] _Wrapped' = iso Map.toAscList Map.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list. +-- | Use @'_Wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ Set a', Ord a) => Rewrapped (Set a) t instance Ord a => Wrapped (Set a) where type Unwrapped (Set a) = [a] @@ -683,6 +679,14 @@ _Wrapped' = iso Storable.toList Storable.fromList {-# INLINE _Wrapped' #-} +#if MIN_VERSION_vector(0,13,2) +instance (t ~ Vector.Vector a') => Rewrapped (VectorStrict.Vector a) t +instance Wrapped (VectorStrict.Vector a) where + type Unwrapped (VectorStrict.Vector a) = [a] + _Wrapped' = iso VectorStrict.toList VectorStrict.fromList + {-# INLINE _Wrapped' #-} +#endif + -- * semigroupoids instance (t ~ WrappedApplicative f' a') => Rewrapped (WrappedApplicative f a) t @@ -753,11 +757,13 @@ _Wrapped' = iso S.unwrapMonoid S.WrapMonoid {-# INLINE _Wrapped' #-} +#if !(MIN_VERSION_base(4,16,0)) instance (t ~ S.Option b) => Rewrapped (S.Option a) t instance Wrapped (S.Option a) where type Unwrapped (S.Option a) = Maybe a _Wrapped' = iso S.getOption S.Option {-# INLINE _Wrapped' #-} +#endif -- * contravariant @@ -855,7 +861,6 @@ _Wrapped' = iso getErrorCall ErrorCall {-# INLINE _Wrapped' #-} -#if MIN_VERSION_base(4,9,0) instance (t ~ TypeError) => Rewrapped TypeError t instance Wrapped TypeError where type Unwrapped TypeError = String @@ -865,7 +870,6 @@ getTypeError :: TypeError -> String getTypeError (TypeError x) = x {-# INLINE getTypeError #-} -#endif #if MIN_VERSION_base(4,10,0) instance (t ~ CompactionFailed) => Rewrapped CompactionFailed t @@ -880,7 +884,7 @@ #endif getErrorCall :: ErrorCall -> String -#if __GLASGOW_HASKELL__ < 800 +#if MIN_VERSION_base(4,21,0) getErrorCall (ErrorCall x) = x #else getErrorCall (ErrorCallWithLocation x _) = x @@ -1011,7 +1015,12 @@ instance Rewrapped CSigAtomic t instance Wrapped CSigAtomic where - type Unwrapped CSigAtomic = HTYPE_SIG_ATOMIC_T + type Unwrapped CSigAtomic = +#if defined(HTYPE_SIG_ATOMIC_T) + HTYPE_SIG_ATOMIC_T +#else + Int32 +#endif _Wrapped' = iso (\(CSigAtomic x) -> x) CSigAtomic {-# INLINE _Wrapped' #-} @@ -1279,10 +1288,10 @@ # endif #endif --- | Given the constructor for a 'Wrapped' type, return a +-- | Given the constructor for a t'Wrapped' type, return a -- deconstructor that is its inverse. -- --- Assuming the 'Wrapped' instance is legal, these laws hold: +-- Assuming the t'Wrapped' instance is legal, these laws hold: -- -- @ -- 'op' f '.' f ≡ 'id' @@ -1357,7 +1366,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 +1380,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 @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} + +#if !MIN_VERSION_transformers(0,6,0) +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} #endif #include "lens-common.h" @@ -33,7 +34,6 @@ import Prelude () import Control.Lens.Getter -import Control.Lens.Internal.Coerce import Control.Lens.Internal.Prelude import Control.Lens.Internal.Zoom import Control.Lens.Type @@ -46,21 +46,24 @@ import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Error +#if MIN_VERSION_mtl(2,3,0) +import Control.Monad.Trans.RWS.CPS as CPS +#endif import Control.Monad.Trans.Except -import Control.Monad.Trans.List import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Free - -#ifdef HLINT -{-# ANN module "HLint: ignore Use fmap" #-} +#if !MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List #endif +import Data.Kind -- $setup -- >>> import Control.Lens --- >>> import Control.Monad.State --- >>> import Data.Map as Map +-- >>> import Control.Monad.State as State +-- >>> import Control.Monad.Reader as Reader +-- >>> import qualified Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f @@ -75,7 +78,7 @@ ------------------------------------------------------------------------------ -- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. -type family Zoomed (m :: * -> *) :: * -> * -> * +type family Zoomed (m :: Type -> Type) :: Type -> Type -> Type type instance Zoomed (Strict.StateT s z) = Focusing z type instance Zoomed (Lazy.StateT s z) = Focusing z type instance Zoomed (ReaderT e m) = Zoomed m @@ -84,22 +87,27 @@ type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) -type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) -type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m) type instance Zoomed (FreeT f m) = FocusingFree f m (Zoomed m) +#if !MIN_VERSION_transformers(0,6,0) +type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) +type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) +#endif ------------------------------------------------------------------------------ -- Magnified ------------------------------------------------------------------------------ -- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. -type family Magnified (m :: * -> *) :: * -> * -> * +type family Magnified (m :: Type -> Type) :: Type -> Type -> Type type instance Magnified (ReaderT b m) = Effect m type instance Magnified ((->)b) = Const type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m +#if MIN_VERSION_mtl(2,3,0) +type instance Magnified (CPS.RWST a w s m) = EffectRWS w s m +#endif type instance Magnified (IdentityT m) = Magnified m ------------------------------------------------------------------------------ @@ -173,31 +181,33 @@ {-# INLINE zoom #-} instance (Monoid w, Zoom m n s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) s t where - zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus #.. l (FocusingPlus #.. afb)) . Strict.runWriterT + zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Strict.runWriterT {-# INLINE zoom #-} instance (Monoid w, Zoom m n s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) s t where - zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #.. l (FocusingPlus #.. afb)) . Lazy.runWriterT + zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Lazy.runWriterT {-# INLINE zoom #-} -instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where - zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT +instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where + zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #. l (FocusingMay #. afb)) . liftM May . runMaybeT {-# INLINE zoom #-} -instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where - zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #.. l (FocusingMay #.. afb)) . liftM May . runMaybeT +instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where + zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runExceptT {-# INLINE zoom #-} +instance (Functor f, Zoom m n s t) => Zoom (FreeT f m) (FreeT f n) s t where + zoom l = FreeT . liftM (fmap (zoom l) . getFreed) . zoom (\afb -> unfocusingFree #. l (FocusingFree #. afb)) . liftM Freed . runFreeT + +#if !MIN_VERSION_transformers(0,6,0) && !MIN_VERSION_mtl(2,3,0) instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where - zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr #.. l (FocusingErr #.. afb)) . liftM Err . runErrorT + zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runErrorT {-# INLINE zoom #-} -instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where - zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #.. l (FocusingErr #.. afb)) . liftM Err . runExceptT +instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where + zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT {-# INLINE zoom #-} - -instance (Functor f, Zoom m n s t) => Zoom (FreeT f m) (FreeT f n) s t where - zoom l = FreeT . liftM (fmap (zoom l) . getFreed) . zoom (\afb -> unfocusingFree #.. l (FocusingFree #.. afb)) . liftM Freed . runFreeT +#endif ------------------------------------------------------------------------------ -- Magnify @@ -269,6 +279,12 @@ instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m) {-# INLINE magnify #-} + +#if MIN_VERSION_mtl(2,3,0) +instance (Monad m, Monoid w, MonadReader b (CPS.RWST b w s m)) => Magnify (CPS.RWST b w s m) (CPS.RWST a w s m) b a where + magnify l m = CPS.rwsT $ getEffectRWS #. l (EffectRWS #. CPS.runRWST m) + {-# INLINE magnify #-} +#endif instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where magnify l (IdentityT m) = IdentityT (magnify l m) diff --git a/src/Control/Monad/Error/Lens.hs b/src/Control/Monad/Error/Lens.hs --- a/src/Control/Monad/Error/Lens.hs +++ b/src/Control/Monad/Error/Lens.hs @@ -40,31 +40,27 @@ import Data.Semigroup (Semigroup(..)) #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use fmap" #-} -#endif - ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ --- | Catch exceptions that match a given 'Prism' (or any 'Getter', really). +-- | Catch exceptions that match a given t'Prism' (or any t'Getter', really). -- -- @ -- 'catching' :: 'MonadError' e m => 'Prism'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Lens'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Traversal'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Iso'' e a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadError' e m => 'Getter' e a -> m r -> (a -> m r) -> m r --- 'catching' :: 'MonadError' e m => 'Fold' e a -> m r -> (a -> m r) -> m r +-- 'catching' :: 'MonadError' e m => t'Getter' e a -> m r -> (a -> m r) -> m r +-- 'catching' :: 'MonadError' e m => t'Fold' e a -> m r -> (a -> m r) -> m r -- @ catching :: MonadError e m => Getting (M.First a) e a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} --- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding +-- | Catch exceptions that match a given t'Prism' (or any t'Getter'), discarding -- the information about the match. This is particularly useful when you have --- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't +-- a @'Prism'' e ()@ where the result of the t'Prism' or t'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- @ @@ -72,8 +68,8 @@ -- 'catching_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r --- 'catching_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r --- 'catching_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r +-- 'catching_' :: 'MonadError' e m => t'Getter' e a -> m r -> m r -> m r +-- 'catching_' :: 'MonadError' e m => t'Fold' e a -> m r -> m r -> m r -- @ catching_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) @@ -91,8 +87,8 @@ -- 'handling' :: 'MonadError' e m => 'Lens'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Traversal'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Iso'' e a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadError' e m => 'Fold' e a -> (a -> m r) -> m r -> m r --- 'handling' :: 'MonadError' e m => 'Getter' e a -> (a -> m r) -> m r -> m r +-- 'handling' :: 'MonadError' e m => t'Fold' e a -> (a -> m r) -> m r -> m r +-- 'handling' :: 'MonadError' e m => t'Getter' e a -> (a -> m r) -> m r -> m r -- @ handling :: MonadError e m => Getting (M.First a) e a -> (a -> m r) -> m r -> m r handling l = flip (catching l) @@ -106,8 +102,8 @@ -- 'handling_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r --- 'handling_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r --- 'handling_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r +-- 'handling_' :: 'MonadError' e m => t'Getter' e a -> m r -> m r -> m r +-- 'handling_' :: 'MonadError' e m => t'Fold' e a -> m r -> m r -> m r -- @ handling_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r handling_ l = flip (catching_ l) @@ -117,16 +113,16 @@ -- Trying ------------------------------------------------------------------------------ --- | 'trying' takes a 'Prism' (or any 'Getter') to select which exceptions are caught --- If the 'Exception' does not match the predicate, it is re-thrown. +-- | 'trying' takes a t'Prism' (or any t'Getter') to select which exceptions are caught +-- If the exception does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadError' e m => 'Prism'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Lens'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Iso'' e a -> m r -> m ('Either' a r) --- 'trying' :: 'MonadError' e m => 'Getter' e a -> m r -> m ('Either' a r) --- 'trying' :: 'MonadError' e m => 'Fold' e a -> m r -> m ('Either' a r) +-- 'trying' :: 'MonadError' e m => t'Getter' e a -> m r -> m ('Either' a r) +-- 'trying' :: 'MonadError' e m => t'Fold' e a -> m r -> m ('Either' a r) -- @ trying :: MonadError e m => Getting (M.First a) e a -> m r -> m (Either a r) trying l m = catching l (liftM Right m) (return . Left) @@ -181,7 +177,7 @@ {-# INLINE fmap #-} instance Monad m => Semigroup (Handler e m a) where - (<>) = M.mappend + (<>) = () {-# INLINE (<>) #-} instance Monad m => Alt (Handler e m) where @@ -197,8 +193,10 @@ instance Monad m => M.Monoid (Handler e m a) where mempty = zero {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend = () {-# INLINE mappend #-} +#endif instance Handleable e m (Handler e m) where handler = Handler . preview @@ -208,13 +206,13 @@ -- Throwing ------------------------------------------------------------------------------ --- | Throw an 'Exception' described by a 'Prism'. +-- | Throw an exception described by a t'Prism'. -- -- @'throwing' l ≡ 'reviews' l 'throwError'@ -- -- @ --- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> a --- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> a +-- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> m a +-- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> m a -- @ throwing :: MonadError e m => AReview e t -> t -> m x throwing l = reviews l throwError diff --git a/src/Control/Parallel/Strategies/Lens.hs b/src/Control/Parallel/Strategies/Lens.hs --- a/src/Control/Parallel/Strategies/Lens.hs +++ b/src/Control/Parallel/Strategies/Lens.hs @@ -14,7 +14,7 @@ -- Stability : provisional -- Portability : portable -- --- A 'Lens' or 'Traversal' can be used to take the role of 'Traversable' in +-- A t'Lens' or t'Traversal' can be used to take the role of 'Traversable' in -- @Control.Parallel.Strategies@, enabling those combinators to work with -- monomorphic containers. ---------------------------------------------------------------------------- @@ -28,7 +28,7 @@ import Control.Lens import Control.Parallel.Strategies --- | Evaluate the targets of a 'Lens' or 'Traversal' into a data structure +-- | Evaluate the targets of a t'Lens' or t'Traversal' into a data structure -- according to the given 'Strategy'. -- -- @ @@ -45,7 +45,7 @@ evalOf l = l {-# INLINE evalOf #-} --- | Evaluate the targets of a 'Lens' or 'Traversal' according into a +-- | Evaluate the targets of a t'Lens' or t'Traversal' according into a -- data structure according to a given 'Strategy' in parallel. -- -- @'parTraversable' = 'parOf' 'traverse'@ @@ -56,14 +56,10 @@ -- 'parOf' :: ((a -> 'Eval' a) -> s -> 'Eval' s) -> 'Strategy' a -> 'Strategy' s -- @ parOf :: LensLike' Eval s a -> Strategy a -> Strategy s -#if MIN_VERSION_parallel(3,2,0) parOf l s = l (rparWith s) -#else -parOf l s = l (rpar `dot` s) -#endif {-# INLINE parOf #-} --- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to +-- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'Traversal' to -- first evaluates its argument according to a given 'Strategy' /before/ proceeding. -- -- @ @@ -73,7 +69,7 @@ after s l f = l f $| s {-# INLINE after #-} --- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to +-- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'Traversal' to -- evaluate its argument according to a given 'Strategy' /in parallel with/ evaluating. -- -- @ diff --git a/src/Control/Seq/Lens.hs b/src/Control/Seq/Lens.hs --- a/src/Control/Seq/Lens.hs +++ b/src/Control/Seq/Lens.hs @@ -7,7 +7,7 @@ -- Stability : provisional -- Portability : portable -- --- A 'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. +-- A t'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. ---------------------------------------------------------------------------- module Control.Seq.Lens ( seqOf @@ -17,8 +17,8 @@ import Control.Seq import Data.Monoid --- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso', --- 'Getter' or 'Fold' according to the given strategy. +-- | Evaluate the elements targeted by a t'Lens', t'Traversal', t'Iso', +-- t'Getter' or t'Fold' according to the given strategy. -- -- @'seqFoldable' = 'seqOf' 'folded'@ seqOf :: Getting (Endo [a]) s a -> Strategy a -> Strategy s diff --git a/src/Data/Array/Lens.hs b/src/Data/Array/Lens.hs --- a/src/Data/Array/Lens.hs +++ b/src/Data/Array/Lens.hs @@ -18,10 +18,10 @@ import Control.Lens import Data.Array.IArray hiding (index) --- | This 'setter' can be used to derive a new 'IArray' from an old 'IAarray' by +-- | This t'Setter' can be used to derive a new 'IArray' from an old 'IArray' by -- applying a function to each of the indices to look it up in the old 'IArray'. -- --- This is a /contravariant/ 'Setter'. +-- This is a /contravariant/ t'Setter'. -- -- @ -- 'ixmap' ≡ 'over' '.' 'ixmapped' @@ -30,5 +30,5 @@ -- 'bounds' ('over' ('ixmapped' b) f arr) ≡ b -- @ ixmapped :: (IArray a e, Ix i, Ix j) => (i,i) -> IndexPreservingSetter (a j e) (a i e) i j -ixmapped = setting . ixmap +ixmapped i = setting $ ixmap i {-# INLINE ixmapped #-} diff --git a/src/Data/Bits/Lens.hs b/src/Data/Bits/Lens.hs --- a/src/Data/Bits/Lens.hs +++ b/src/Data/Bits/Lens.hs @@ -28,39 +28,40 @@ import Data.Bits import Data.Word - -- $setup -- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens +-- >>> import Control.Monad.State -- >>> import Data.Word infixr 4 .|.~, .&.~, <.|.~, <.&.~, <<.|.~, <<.&.~ infix 4 .|.=, .&.=, <.|.=, <.&.=, <<.|.=, <<.&.= --- | Bitwise '.|.' the target(s) of a 'Lens' or 'Setter'. +-- | Bitwise '.|.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .|.~ 6 $ ("hello",3) -- ("hello",7) -- -- @ --- ('.|.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t --- ('.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t --- ('.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t --- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => t'Setter' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> t +-- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => t'Traversal' s t a a -> a -> s -> t -- @ (.|.~):: Bits a => ASetter s t a a -> a -> s -> t l .|.~ n = over l (.|. n) {-# INLINE (.|.~) #-} --- | Bitwise '.&.' the target(s) of a 'Lens' or 'Setter'. +-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .&.~ 7 $ ("hello",254) -- ("hello",6) -- -- @ --- ('.&.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t --- ('.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t --- ('.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t --- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => t'Setter' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> t +-- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => t'Traversal' s t a a -> a -> s -> t -- @ (.&.~) :: Bits a => ASetter s t a a -> a -> s -> t l .&.~ n = over l (.&. n) @@ -81,7 +82,7 @@ l .&.= a = modify (l .&.~ a) {-# INLINE (.&.=) #-} --- | Modify the target(s) of a 'Lens'', 'Setter' or 'Traversal' by computing its bitwise '.|.' with another value. +-- | Modify the target(s) of a 'Lens'', t'Setter' or t'Traversal' by computing its bitwise '.|.' with another value. -- -- >>> execState (do _1 .|.= 15; _2 .|.= 3) (7,7) -- (15,7) @@ -96,31 +97,31 @@ l .|.= a = modify (l .|.~ a) {-# INLINE (.|.=) #-} --- | Bitwise '.|.' the target(s) of a 'Lens' (or 'Traversal'), returning the result +-- | Bitwise '.|.' the target(s) of a t'Lens' (or t'Traversal'), returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.|.~ 6 $ ("hello",3) -- (7,("hello",7)) -- -- @ --- ('<.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) --- ('<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<.|.~):: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) l <.|.~ n = l <%~ (.|. n) {-# INLINE (<.|.~) #-} --- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', returning the result +-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Traversal', returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.&.~ 7 $ ("hello",254) -- (6,("hello",6)) -- -- @ --- ('<.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) --- ('<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<.&.~) :: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) l <.&.~ n = l <%~ (.&. n) @@ -140,7 +141,7 @@ l <.&.= b = l <%= (.&. b) {-# INLINE (<.&.=) #-} --- | Modify the target(s) of a 'Lens'', (or 'Traversal') by computing its bitwise '.|.' with another value, +-- | Modify the target(s) of a 'Lens'', (or t'Traversal') by computing its bitwise '.|.' with another value, -- returning the result (or a monoidal summary of all of the results traversed). -- -- >>> runState (_1 <.|.= 7) (28,0) @@ -154,7 +155,7 @@ l <.|.= b = l <%= (.|. b) {-# INLINE (<.|.=) #-} --- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', and return the +-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Traversal', and return the -- original value, or a monoidal summary of the original values. -- -- When you do not need the old value, ('.&.~') is more flexible. @@ -163,15 +164,15 @@ -- (254,("hello",6)) -- -- @ --- ('<<.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) --- ('<<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<<.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) +-- ('<<.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) +-- ('<<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<<.&.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.&.~ b = l $ \a -> (a, a .&. b) {-# INLINE (<<.&.~) #-} --- | Bitwise '.|.' the target(s) of a 'Lens' or 'Traversal', and return the +-- | Bitwise '.|.' the target(s) of a t'Lens' or t'Traversal', and return the -- original value, or a monoidal summary of the original values. -- -- When you do not need the old value, ('.|.~') is more flexible. @@ -180,9 +181,9 @@ -- (3,("hello",7)) -- -- @ --- ('<<.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) --- ('<<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<<.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t) +-- ('<<.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t) +-- ('<<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<<.|.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.|.~ b = l $ \a -> (a, a .|. b) @@ -222,9 +223,9 @@ l <<.|.= b = l %%= \a -> (a, a .|. b) {-# INLINE (<<.|.=) #-} --- | This 'Lens' can be used to access the value of the nth bit in a number. +-- | This t'Lens' can be used to access the value of the nth bit in a number. -- --- @'bitAt' n@ is only a legal 'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@. +-- @'bitAt' n@ is only a legal t'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@. -- -- >>> 16^.bitAt 4 -- True @@ -243,7 +244,7 @@ -- | Get the nth byte, counting from the low end. -- --- @'byteAt' n@ is a legal 'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@ +-- @'byteAt' n@ is a legal t'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@ -- -- >>> (0xff00 :: Word16)^.byteAt 0 -- 0 @@ -270,7 +271,7 @@ -- >>> toListOf bits (5 :: Word8) -- [True,False,True,False,False,False,False,False] -- --- If you supply this an 'Integer', the result will be an infinite 'Traversal', which +-- If you supply this an 'Integer', the result will be an infinite t'Traversal', which -- can be productively consumed, but not reassembled. bits :: (Num b, Bits b) => IndexedTraversal' Int b Bool bits f b = foldr step 0 <$> traverse g bs where @@ -288,7 +289,7 @@ -- >>> toListOf bytewise (1312301580 :: Word32) -- [12,34,56,78] -- --- If you supply this an 'Integer', the result will be an infinite 'Traversal', +-- If you supply this an 'Integer', the result will be an infinite t'Traversal', -- which can be productively consumed, but not reassembled. -- -- Why isn't this function called @bytes@ to match 'bits'? Alas, there diff --git a/src/Data/ByteString/Lazy/Lens.hs b/src/Data/ByteString/Lazy/Lens.hs --- a/src/Data/ByteString/Lazy/Lens.hs +++ b/src/Data/ByteString/Lazy/Lens.hs @@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} - -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -#endif ----------------------------------------------------------------------------- -- | @@ -20,22 +17,23 @@ module Data.ByteString.Lazy.Lens ( packedBytes, unpackedBytes, bytes , packedChars, unpackedChars, chars -#if __GLASGOW_HASKELL__ >= 710 , pattern Bytes , pattern Chars -#endif ) where import Control.Lens import Control.Lens.Internal.ByteString -import Data.ByteString.Lazy as Words -import Data.ByteString.Lazy.Char8 as Char8 +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as Words +import qualified Data.ByteString.Lazy.Char8 as Char8 import Data.Word (Word8) import Data.Int (Int64) -- $setup -- >>> :set -XOverloadedStrings +-- >>> import Control.Lens -- >>> import Numeric.Lens +-- >>> import qualified Data.ByteString.Lazy.Char8 as Char8 -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString'. -- @@ -48,7 +46,7 @@ -- >>> [104,101,108,108,111]^.packedBytes == Char8.pack "hello" -- True packedBytes :: Iso' [Word8] ByteString -packedBytes = iso Words.pack unpackLazy +packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} -- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a 'ByteString' into a list of bytes @@ -67,7 +65,7 @@ -- | Traverse the individual bytes in a 'ByteString'. -- --- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion +-- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to the much slower: @@ -79,7 +77,7 @@ -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False -- --- Note that when just using this as a 'Setter', @'setting' 'Data.ByteString.Lazy.map'@ +-- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.Lazy.map'@ -- can be more efficient. bytes :: IndexedTraversal' Int64 ByteString Word8 bytes = traversedLazy @@ -99,7 +97,7 @@ -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString -packedChars = iso Char8.pack unpackLazy8 +packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} -- | 'Data.ByteString.Lazy.Char8.unpack' (or 'Data.ByteString.Lazy.Char8.pack') a list of characters into a 'ByteString' @@ -124,7 +122,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- --- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion +-- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to: @@ -139,10 +137,10 @@ chars = traversedLazy8 {-# INLINE chars #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Bytes :: [Word8] -> ByteString pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b +pattern Chars :: String -> ByteString pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b -#endif diff --git a/src/Data/ByteString/Lens.hs b/src/Data/ByteString/Lens.hs --- a/src/Data/ByteString/Lens.hs +++ b/src/Data/ByteString/Lens.hs @@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens @@ -18,17 +16,15 @@ ( IsByteString(..) , unpackedBytes , unpackedChars -#if __GLASGOW_HASKELL__ >= 710 , pattern Bytes , pattern Chars -#endif ) where import Control.Lens import Data.Word (Word8) -import Data.ByteString as Strict +import qualified Data.ByteString as Strict import qualified Data.ByteString.Strict.Lens as Strict -import Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Lens as Lazy -- | Traversals for ByteStrings. @@ -57,7 +53,7 @@ -- | Traverse each 'Word8' in a strict or lazy 'ByteString' -- -- - -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion + -- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to the much slower: @@ -78,7 +74,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- - -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion + -- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion -- enable zippers to seek to locations more quickly and accelerate -- many monoidal queries, but up to associativity (and constant factors) it is -- equivalent to the much slower: @@ -110,13 +106,13 @@ unpackedBytes = from packedBytes {-# INLINE unpackedBytes #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Bytes :: IsByteString s => [Word8] -> s pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b - + +pattern Chars :: IsByteString s => String -> s pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b -#endif -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a strict (or lazy) 'ByteString' -- diff --git a/src/Data/ByteString/Strict/Lens.hs b/src/Data/ByteString/Strict/Lens.hs --- a/src/Data/ByteString/Strict/Lens.hs +++ b/src/Data/ByteString/Strict/Lens.hs @@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -#endif ----------------------------------------------------------------------------- -- | @@ -18,22 +16,22 @@ module Data.ByteString.Strict.Lens ( packedBytes, unpackedBytes, bytes , packedChars, unpackedChars, chars -#if __GLASGOW_HASKELL__ >= 710 , pattern Bytes , pattern Chars -#endif ) where import Control.Lens import Control.Lens.Internal.ByteString -import Data.ByteString as Words -import Data.ByteString.Char8 as Char8 +import Data.ByteString (ByteString) +import qualified Data.ByteString as Words +import qualified Data.ByteString.Char8 as Char8 import Data.Word -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens +-- >>> import qualified Data.ByteString.Char8 as Char8 -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' -- @@ -46,7 +44,7 @@ -- >>> [104,101,108,108,111]^.packedBytes -- "hello" packedBytes :: Iso' [Word8] ByteString -packedBytes = iso Words.pack unpackStrict +packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes @@ -65,7 +63,7 @@ -- | Traverse each 'Word8' in a 'ByteString'. -- --- This 'Traversal' walks the 'ByteString' in a tree-like fashion +-- This t'Traversal' walks the 'ByteString' in a tree-like fashion -- enable zippers to seek to locations in logarithmic time and accelerating -- many monoidal queries, but up to associativity (and constant factors) -- it is equivalent to the much slower: @@ -77,7 +75,7 @@ -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False -- --- Note that when just using this as a 'Setter', @'setting' 'Data.ByteString.map'@ +-- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.map'@ -- can be more efficient. bytes :: IndexedTraversal' Int ByteString Word8 bytes = traversedStrictTree @@ -97,7 +95,7 @@ -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString -packedChars = iso Char8.pack unpackStrict8 +packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a 'ByteString' @@ -122,7 +120,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. -- --- This 'Traversal' walks the 'ByteString' in a tree-like fashion +-- This t'Traversal' walks the 'ByteString' in a tree-like fashion -- enable zippers to seek to locations in logarithmic time and accelerating -- many monoidal queries, but up to associativity (and constant factors) -- it is equivalent to the much slower: @@ -137,11 +135,10 @@ chars = traversedStrictTree8 {-# INLINE chars #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Bytes :: [Word8] -> ByteString pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b +pattern Chars :: String -> ByteString pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b -#endif - diff --git a/src/Data/Complex/Lens.hs b/src/Data/Complex/Lens.hs --- a/src/Data/Complex/Lens.hs +++ b/src/Data/Complex/Lens.hs @@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -#endif ----------------------------------------------------------------------------- -- | @@ -24,13 +22,11 @@ , _magnitude , _phase , _conjugate -#if __GLASGOW_HASKELL__ >= 710 -- * Pattern Synonyms , pattern Polar , pattern Real , pattern Imaginary , pattern Conjugate -#endif ) where import Prelude () @@ -40,6 +36,8 @@ import Data.Complex -- $setup +-- >>> import Control.Lens +-- >>> import Data.Complex -- >>> import Debug.SimpleReflect -- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ } @@ -69,7 +67,7 @@ _imagPart f (a :+ b) = (a :+) <$> f b {-# INLINE _imagPart #-} --- | This isn't /quite/ a legal 'Lens'. Notably the +-- | This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- @@ -78,32 +76,34 @@ -- which flips the 'phase' and retains a positive 'magnitude'. So don't do -- that! -- --- Otherwise, this is a perfectly cromulent 'Lens'. +-- Otherwise, this is a perfectly cromulent t'Lens'. _polar :: RealFloat a => Iso' (Complex a) (a,a) _polar = iso polar (uncurry mkPolar) {-# INLINE _polar #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Polar :: RealFloat a => a -> a -> Complex a pattern Polar m theta <- (view _polar -> (m, theta)) where Polar m theta = review _polar (m, theta) +pattern Real :: (Eq a, Num a) => a -> Complex a pattern Real r = r :+ 0 + +pattern Imaginary :: (Eq a, Num a) => a -> Complex a pattern Imaginary i = 0 :+ i -#endif -- | Access the 'magnitude' of a 'Complex' number. -- -- >>> (10.0 :+ 20.0) & _magnitude *~ 2 -- 20.0 :+ 40.0 -- --- This isn't /quite/ a legal 'Lens'. Notably the +-- This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a negative 'magnitude'. This flips the 'phase' -- and retains a positive 'magnitude'. So don't do that! -- --- Otherwise, this is a perfectly cromulent 'Lens'. +-- Otherwise, this is a perfectly cromulent t'Lens'. -- -- Setting the 'magnitude' of a zero 'Complex' number assumes the 'phase' is 0. _magnitude :: RealFloat a => Lens' (Complex a) a @@ -118,14 +118,14 @@ -- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2 -- True -- --- This isn't /quite/ a legal 'Lens'. Notably the +-- This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a 'phase' outside the range @(-'pi', 'pi']@. -- The phase is always in that range when queried. So don't do that! -- --- Otherwise, this is a perfectly cromulent 'Lens'. +-- Otherwise, this is a perfectly cromulent t'Lens'. _phase :: RealFloat a => Lens' (Complex a) a _phase f c = setPhase <$> f theta where setPhase theta' = c * cis (theta' - theta) @@ -143,7 +143,6 @@ _conjugate = involuted conjugate {-# INLINE _conjugate #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Conjugate :: Num a => Complex a -> Complex a pattern Conjugate a <- (conjugate -> a) where Conjugate a = conjugate a -#endif 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,13 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} -#ifndef HLINT {-# LANGUAGE UnboxedTuples #-} -#endif {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} @@ -15,12 +12,6 @@ {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fno-full-laziness #-} -#if __GLASGOW_HASKELL__ >= 810 --- Use -fbyte-code explicitly to ensure that -fobject-code isn't automatically --- implied on GHCi 8.10+ by the use of UnboxedTuples, as this breaks the --- doctests. See #874 for more details. -{-# OPTIONS_GHC -fbyte-code #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Data.Lens @@ -74,19 +65,14 @@ 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 +-- >>> import Control.Lens.Internal.Doctest +-- >>> import Prelude hiding (head, tail) ------------------------------------------------------------------------------- -- Generic Traversal @@ -150,7 +136,7 @@ -- Automatic Traversal construction from field accessors ------------------------------------------------------------------------------ -data FieldException a = FieldException !Int a deriving Typeable +data FieldException a = FieldException !Int a instance Show (FieldException a) where showsPrec d (FieldException i _) = showParen (d > 10) $ @@ -332,13 +318,11 @@ where x' = f x {-# INLINE fixEq #-} -#ifndef HLINT -- | inlineable 'unsafePerformIO' inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-} -#endif ------------------------------------------------------------------------------- -- Cache @@ -402,9 +386,9 @@ 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 + go = gfoldl (\x y -> x <*> go2 y) pure go2 :: Data d => d -> f d go2 s = case o s of Hit a -> f a @@ -413,9 +397,9 @@ {-# 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 + go = gfoldl (\x y -> x <*> go2 y) pure go2 :: Data d => d -> f d go2 s = case o s of Hit a -> f a diff --git a/src/Data/Dynamic/Lens.hs b/src/Data/Dynamic/Lens.hs --- a/src/Data/Dynamic/Lens.hs +++ b/src/Data/Dynamic/Lens.hs @@ -1,11 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic.Lens @@ -18,9 +14,7 @@ ---------------------------------------------------------------------------- module Data.Dynamic.Lens ( AsDynamic(..) -#if __GLASGOW_HASKELL__ >= 710 , pattern Data.Dynamic.Lens.Dynamic -#endif ) where import Control.Exception @@ -28,16 +22,16 @@ import Control.Lens import Data.Dynamic --- | Any 'Dynamic' can be thrown as an 'Exception' +-- | Any t'Dynamic' can be thrown as an t'Exception' class AsDynamic t where - -- | This 'Prism' allows you to traverse the typed value contained in a - -- 'Dynamic' where the type required by your function matches that - -- of the contents of the 'Dynamic', or construct a 'Dynamic' value - -- out of whole cloth. It can also be used to catch or throw a 'Dynamic' + -- | This t'Prism' allows you to traverse the typed value contained in a + -- t'Dynamic' where the type required by your function matches that + -- of the contents of the t'Dynamic', or construct a t'Dynamic' value + -- out of whole cloth. It can also be used to catch or throw a t'Dynamic' -- value as 'SomeException'. -- -- @ - -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'Dynamic' a + -- '_Dynamic' :: 'Typeable' a => 'Prism'' t'Dynamic' a -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'SomeException' a -- @ _Dynamic :: Typeable a => Prism' t a @@ -50,7 +44,6 @@ _Dynamic = exception.prism' toDyn fromDynamic {-# INLINE _Dynamic #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Dynamic :: (AsDynamic s, Typeable a) => a -> s pattern Dynamic a <- (preview _Dynamic -> Just a) where Dynamic a = review _Dynamic a -#endif 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 @@ -12,12 +12,16 @@ module Data.HashSet.Lens ( setmapped , setOf + , hashMap ) where import Control.Lens.Getter (Getting, views) +import Control.Lens.Iso (iso) import Control.Lens.Setter (setting) import Control.Lens.Type -import Data.HashSet as HashSet +import qualified Data.HashSet as HashSet +import Data.HashSet (HashSet, fromMap, toMap) +import Data.HashMap.Lazy (HashMap) import Data.Hashable -- $setup @@ -45,3 +49,7 @@ setOf :: Hashable a => Getting (HashSet a) s a -> s -> HashSet a setOf l = views l HashSet.singleton {-# INLINE setOf #-} + +-- | An `Iso` between a `HashSet` and a `HashMap` with unit values. \(\mathcal{O}(1)\). +hashMap :: Iso' (HashSet a) (HashMap a ()) +hashMap = iso toMap fromMap diff --git a/src/Data/IntSet/Lens.hs b/src/Data/IntSet/Lens.hs --- a/src/Data/IntSet/Lens.hs +++ b/src/Data/IntSet/Lens.hs @@ -16,13 +16,15 @@ ) where import Control.Lens -import Data.IntSet as IntSet +import qualified Data.IntSet as IntSet +import Data.IntSet (IntSet) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens +-- >>> import qualified Data.IntSet as IntSet --- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of an 'IntSet'. +-- | IntSet isn't Foldable, but this t'Fold' can be used to access the members of an 'IntSet'. -- -- >>> sumOf members $ setOf folded [1,2,3,4] -- 10 @@ -30,20 +32,20 @@ members = folding IntSet.toAscList {-# INLINE members #-} --- | This 'Setter' can be used to change the contents of an 'IntSet' by mapping +-- | This t'Setter' can be used to change the contents of an 'IntSet' by mapping -- the elements to new values. -- --- Sadly, you can't create a valid 'Traversal' for a 'Set', because the number of +-- Sadly, you can't create a valid t'Traversal' for an 'IntSet', because the number of -- elements might change but you can manipulate it by reading using 'folded' and -- reindexing it via 'setmapped'. -- --- >>> over setmapped (+1) (fromList [1,2,3,4]) +-- >>> over setmapped (+1) (IntSet.fromList [1,2,3,4]) -- fromList [2,3,4,5] setmapped :: IndexPreservingSetter' IntSet Int setmapped = setting IntSet.map {-# INLINE setmapped #-} --- | Construct an 'IntSet' from a 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'. +-- | Construct an 'IntSet' from a t'Getter', t'Fold', t'Traversal', t'Lens' or t'Iso'. -- -- >>> setOf folded [1,2,3,4] -- fromList [1,2,3,4] @@ -52,11 +54,11 @@ -- fromList [1,2,3] -- -- @ --- 'setOf' :: 'Getter' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Fold' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Iso'' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Lens'' s 'Int' -> s -> 'IntSet' --- 'setOf' :: 'Traversal'' s 'Int' -> s -> 'IntSet' +-- 'setOf' :: t'Getter' s 'Int' -> s -> 'IntSet' +-- 'setOf' :: t'Fold' s 'Int' -> s -> 'IntSet' +-- 'setOf' :: t'Iso'' s 'Int' -> s -> 'IntSet' +-- 'setOf' :: t'Lens'' s 'Int' -> s -> 'IntSet' +-- 'setOf' :: t'Traversal'' s 'Int' -> s -> 'IntSet' -- @ setOf :: Getting IntSet s Int -> s -> IntSet setOf l = views l IntSet.singleton diff --git a/src/Data/List/Lens.hs b/src/Data/List/Lens.hs --- a/src/Data/List/Lens.hs +++ b/src/Data/List/Lens.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Data.List.Lens @@ -68,6 +65,20 @@ -- >>> "live" & reversed %~ ('d':) -- "lived" -- +-- It's possible to work under a prefix or suffix of a list using +-- 'Control.Lens.Prism.Prefixed' and 'Control.Lens.Prism.Suffixed'. +-- +-- >>> "preview" ^? prefixed "pre" +-- Just "view" +-- +-- >>> suffixed ".o" # "hello" +-- "hello.o" +-- +-- At present, "Data.List.Lens" re-exports 'Prefixed' and 'Suffixed' for +-- backwards compatibility, as 'prefixed' and 'suffixed' used to be top-level +-- functions defined in this module. This may change in a future major release +-- of @lens@. +-- -- Finally, it's possible to traverse, fold over, and map over -- index-value pairs thanks to instances of -- 'Control.Lens.Indexed.TraversableWithIndex', @@ -89,67 +100,14 @@ -- ---------------------------------------------------------------------------- module Data.List.Lens - ( prefixed - , suffixed + ( Prefixed(..) + , Suffixed(..) , stripSuffix ) where -import Prelude () - -import Control.Monad (guard) -import Control.Lens.Internal.Prelude -import Control.Lens -import Data.List - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> import Debug.SimpleReflect.Expr --- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) --- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f --- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g - --- | A 'Prism' stripping a prefix from a list when used as a 'Traversal', or --- prepending that prefix when run backwards: --- --- >>> "preview" ^? prefixed "pre" --- Just "view" --- --- >>> "review" ^? prefixed "pre" --- Nothing --- --- >>> prefixed "pre" # "amble" --- "preamble" -prefixed :: Eq a => [a] -> Prism' [a] [a] -prefixed ps = prism' (ps ++) (stripPrefix ps) -{-# INLINE prefixed #-} - --- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or --- appending that suffix when run backwards: --- --- >>> "review" ^? suffixed "view" --- Just "re" --- --- >>> "review" ^? suffixed "tire" --- Nothing --- --- >>> suffixed ".o" # "hello" --- "hello.o" -suffixed :: Eq a => [a] -> Prism' [a] [a] -suffixed qs = prism' (++ qs) (stripSuffix qs) -{-# INLINE suffixed #-} - ------------------------------------------------------------------------------- --- Util ------------------------------------------------------------------------------- +import Control.Lens.Prism (Prefixed(..), Suffixed(..)) +import Control.Lens.Internal.List (stripSuffix) -stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] -stripSuffix qs xs0 = go xs0 zs - where - zs = drp qs xs0 - drp (_:ps) (_:xs) = drp ps xs - drp [] xs = xs - drp _ [] = [] - go (_:xs) (_:ys) = go xs ys - go xs [] = zipWith const xs0 zs <$ guard (xs == qs) - go [] _ = Nothing -- impossible -{-# INLINE stripSuffix #-} +--- $setup +--- >>> :set -XNoOverloadedStrings +--- >>> import Control.Lens 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 @@ -118,7 +122,7 @@ (m, r) -> itraverse (indexed f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-} --- | Construct a 'Seq' from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. +-- | Construct a 'Seq' from a t'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. -- -- >>> seqOf folded ["hello","world"] -- fromList ["hello","world"] @@ -127,8 +131,8 @@ -- fromList [1,2,3] -- -- @ --- 'seqOf' :: 'Getter' s a -> s -> 'Seq' a --- 'seqOf' :: 'Fold' s a -> s -> 'Seq' a +-- 'seqOf' :: t'Getter' s a -> s -> 'Seq' a +-- 'seqOf' :: t'Fold' s a -> s -> 'Seq' a -- 'seqOf' :: 'Iso'' s a -> s -> 'Seq' a -- 'seqOf' :: 'Lens'' s a -> s -> 'Seq' a -- 'seqOf' :: 'Traversal'' s a -> s -> 'Seq' a diff --git a/src/Data/Set/Lens.hs b/src/Data/Set/Lens.hs --- a/src/Data/Set/Lens.hs +++ b/src/Data/Set/Lens.hs @@ -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 @@ -1,10 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lazy.Lens @@ -21,9 +19,7 @@ , text , builder , utf8 -#if __GLASGOW_HASKELL__ >= 710 , pattern Text -#endif ) where import Control.Lens.Type @@ -31,20 +27,21 @@ import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Prism -#if __GLASGOW_HASKELL__ >= 710 import Control.Lens.Review -#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 +95,7 @@ -- 'toLazyText' x ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder -builder = iso fromLazyText toLazyText +builder = iso Builder.fromLazyText Builder.toLazyText {-# INLINE builder #-} -- | Traverse the individual characters in a 'Text'. @@ -148,7 +145,6 @@ utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') {-# INLINE utf8 #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Text :: String -> Text pattern Text a <- (view _Text -> a) where Text a = review _Text a -#endif diff --git a/src/Data/Text/Lens.hs b/src/Data/Text/Lens.hs --- a/src/Data/Text/Lens.hs +++ b/src/Data/Text/Lens.hs @@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} - -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lens @@ -20,26 +17,23 @@ ( IsText(..) , unpacked , _Text -#if __GLASGOW_HASKELL__ >= 710 , pattern Text -#endif ) where import Control.Lens.Type -#if __GLASGOW_HASKELL__ >= 710 import Control.Lens.Getter import Control.Lens.Review -#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 @@ -105,10 +99,9 @@ _Text = from packed {-# INLINE _Text #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Text :: IsText s => String -> s pattern Text a <- (view _Text -> a) where Text a = review _Text a -#endif instance IsText Strict.Text where packed = Strict.packed diff --git a/src/Data/Text/Strict/Lens.hs b/src/Data/Text/Strict/Lens.hs --- a/src/Data/Text/Strict/Lens.hs +++ b/src/Data/Text/Strict/Lens.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Strict.Lens @@ -20,9 +18,7 @@ , text , utf8 , _Text -#if __GLASGOW_HASKELL__ >= 710 , pattern Text -#endif ) where import Control.Lens.Type @@ -30,17 +26,17 @@ import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Prism -#if __GLASGOW_HASKELL__ >= 710 import Control.Lens.Review -#endif import Control.Lens.Setter 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 +55,7 @@ -- 'packed' ≡ 'iso' 'pack' 'unpack' -- @ packed :: Iso' String Text -packed = iso pack unpack +packed = iso Strict.pack Strict.unpack {-# INLINE packed #-} -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'. @@ -79,7 +75,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 +93,7 @@ -- 'toStrict' ('toLazyText' x) ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder -builder = iso fromText (toStrict . toLazyText) +builder = iso Builder.fromText (toStrict . Builder.toLazyText) {-# INLINE builder #-} -- | Traverse the individual characters in strict 'Text'. @@ -141,7 +137,6 @@ utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') {-# INLINE utf8 #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern Text :: String -> Text pattern Text a <- (view _Text -> a) where Text a = review _Text a -#endif 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,7 +23,11 @@ import Control.Lens import Data.Tree --- | A 'Lens' that focuses on the root of a 'Tree'. +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Tree + +-- | A t'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 [] -- 42 @@ -31,7 +35,7 @@ root f (Node a as) = (`Node` as) <$> f a {-# INLINE root #-} --- | A 'Lens' returning the direct descendants of the root of a 'Tree' +-- | A t'Lens' returning the direct descendants of the root of a 'Tree' -- -- @'view' 'branches' ≡ 'subForest'@ branches :: Lens' (Tree a) [Tree a] diff --git a/src/Data/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,19 +47,15 @@ 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 Data.Vector.Generic.New (New) -import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) - -#if MIN_VERSION_vector(0,11,0) +import Control.Lens.Internal.Prelude import Data.Vector.Fusion.Bundle (Bundle) -#else -import Data.Vector.Fusion.Stream (Stream) -#endif +import qualified Data.Vector.Generic as V +import Data.Vector.Generic (Vector) +import Data.Vector.Generic.New (New) -- $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 +75,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 +83,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,41 +94,30 @@ -- >>> 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) -- | Convert a 'Vector' to a finite 'Bundle' (or back.) asStream :: (Vector v a, Vector v b) => Iso (v a) (v b) (Bundle v a) (Bundle v b) -#else --- | 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) -- | Convert a 'Vector' to a finite 'Bundle' from right to left (or -- back.) asStreamR :: (Vector v a, Vector v b) => Iso (v a) (v b) (Bundle v a) (Bundle v b) -#else --- | Convert a 'Vector' to a finite 'Stream' from right to left (or --- 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 +126,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 +150,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,21 +28,26 @@ , 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) --- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting --- at index @i@ from a 'Lens'. +-- $setup +-- >>> import qualified Data.Vector as Vector +-- >>> import Control.Lens + +-- | @sliced i n@ provides a t'Lens' that edits the @n@ elements starting +-- at index @i@ from a t'Lens'. -- --- This is only a valid 'Lens' if you do not change the length of the +-- This is only a valid t'Lens' if you do not change the length of the -- resulting 'Vector'. -- -- Attempting to return a longer or shorter vector will result in --- violations of the 'Lens' laws. +-- violations of the t'Lens' laws. -- -- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] -- True @@ -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,20 +79,20 @@ -- >>> Vector.fromList [0,8,15] ^. from vector . vector == Vector.fromList [0,8,15] -- True vector :: Iso [a] [b] (Vector a) (Vector b) -vector = iso fromList toList +vector = iso V.fromList V.toList {-# INLINE vector #-} -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b) -forced = iso force force +forced = iso V.force V.force {-# INLINE forced #-} --- | This 'Traversal' will ignore any duplicates in the supplied list +-- | This t'Traversal' will ignore any duplicates in the supplied list -- of indices. -- -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: [Int] -> IndexedTraversal' Int (Vector a) a -ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ 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 @@ -1,12 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens @@ -58,29 +56,25 @@ import qualified GHC.Generics as Generic import GHC.Generics hiding (from, to) -#if !(MIN_VERSION_base(4,9,0)) -import Generics.Deriving.Base hiding (from, to) -#endif - -- $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 #-} _V1 :: Over p f (V1 s) (V1 t) a b -_V1 _ = absurd where - absurd !_a = undefined +_V1 _ = \case {-# INLINE _V1 #-} _U1 :: Iso (U1 p) (U1 q) () () @@ -88,19 +82,19 @@ {-# INLINE _U1 #-} _Par1 :: Iso (Par1 p) (Par1 q) p q -_Par1 = iso unPar1 Par1 +_Par1 = coerced {-# INLINE _Par1 #-} _Rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q) -_Rec1 = iso unRec1 Rec1 +_Rec1 = coerced {-# INLINE _Rec1 #-} _K1 :: Iso (K1 i c p) (K1 j d q) c d -_K1 = iso unK1 K1 +_K1 = coerced {-# INLINE _K1 #-} _M1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q) -_M1 = iso unM1 M1 +_M1 = coerced {-# INLINE _M1 #-} _L1 :: Prism' ((f :+: g) a) (f a) @@ -111,7 +105,8 @@ reviewer x = Left x {-# INLINE _L1 #-} --- | You can access fields of `data (f :*: g) p` by using it's `Field1` and `Field2` instances +-- | You can access fields of `data (f :*: g) p` by using its `Field1` and +-- `Field2` instances. _R1 :: Prism' ((f :+: g) a) (g a) _R1 = prism remitter reviewer 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,15 +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 , injectivityAnnInputs @@ -81,7 +79,6 @@ -- ** Bang Lenses , bangSourceUnpackedness , bangSourceStrictness -#endif #if MIN_VERSION_template_haskell(2,12,0) -- ** DerivClause Lenses , derivClauseStrategy @@ -110,27 +107,17 @@ , _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 -#endif -#if MIN_VERSION_template_haskell(2,11,0) , _DataFamilyD , _OpenTypeFamilyD -#else - , _FamilyD -#endif #if MIN_VERSION_template_haskell(2,12,0) , _PatSynD , _PatSynSigD @@ -138,6 +125,12 @@ #if MIN_VERSION_template_haskell(2,15,0) , _ImplicitParamBindD #endif +#if MIN_VERSION_template_haskell(2,19,0) + , _DefaultD +#endif +#if MIN_VERSION_template_haskell(2,20,0) + , _TypeDataD +#endif #if MIN_VERSION_template_haskell(2,12,0) -- ** PatSynDir Prisms , _Unidir @@ -153,18 +146,19 @@ , _RecC , _InfixC , _ForallC -#if MIN_VERSION_template_haskell(2,11,0) , _GadtC , _RecGadtC +#if MIN_VERSION_template_haskell(2,22,0) + -- ** NamespaceSpecifier Prisms + , _NoNamespaceSpecifier + , _TypeNamespaceSpecifier + , _DataNamespaceSpecifier #endif -#if MIN_VERSION_template_haskell(2,11,0) -- ** Overlap Prisms ,_Overlappable ,_Overlapping ,_Overlaps ,_Incoherent -#endif -#if MIN_VERSION_template_haskell(2,11,0) -- ** SourceUnpackedness Prisms , _NoSourceUnpackedness , _SourceNoUnpack @@ -177,23 +171,15 @@ , _DecidedLazy , _DecidedStrict , _DecidedUnpack -#else - -- ** Strict Prisms - , _IsStrict - , _NotStrict - , _Unpacked -#endif -- ** Foreign Prisms , _ImportF , _ExportF -- ** Callconv Prisms , _CCall , _StdCall -#if MIN_VERSION_template_haskell(2,10,0) , _CApi , _Prim , _JavaScript -#endif -- ** Safety Prisms , _Unsafe , _Safe @@ -201,18 +187,22 @@ -- ** 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 #if MIN_VERSION_template_haskell(2,12,0) , _CompleteP #endif +#if MIN_VERSION_template_haskell(2,19,0) + , _OpaqueP +#endif +#if MIN_VERSION_template_haskell(2,22,0) + , _SCCP +#endif +#if MIN_VERSION_template_haskell(2,24,0) + , _SpecialiseEP +#endif -- ** Inline Prisms , _NoInline , _Inline @@ -227,13 +217,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 +244,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 @@ -278,12 +261,8 @@ , _SigE , _RecConE , _RecUpdE -#if MIN_VERSION_template_haskell(2,10,0) , _StaticE -#endif -#if MIN_VERSION_template_haskell(2,11,0) , _UnboundVarE -#endif #if MIN_VERSION_template_haskell(2,13,0) , _LabelE #endif @@ -291,6 +270,25 @@ , _MDoE , _ImplicitParamVarE #endif +#if MIN_VERSION_template_haskell(2,18,0) + , _GetFieldE + , _ProjectionE +#endif +#if MIN_VERSION_template_haskell(2,19,0) + , _LamCasesE +#endif +#if MIN_VERSION_template_haskell(2,21,0) + , _TypedBracketE + , _TypedSpliceE +#endif +#if MIN_VERSION_template_haskell(2,22,0) + , _TypeE +#endif +#if MIN_VERSION_template_haskell(2,23,0) + , _ForallE + , _ForallVisE + , _ConstrainedE +#endif -- ** Body Prisms , _GuardedB , _NormalB @@ -320,9 +318,7 @@ , _FloatPrimL , _DoublePrimL , _StringPrimL -#if MIN_VERSION_template_haskell(2,11,0) , _CharPrimL -#endif #if MIN_VERSION_template_haskell(2,16,0) , _BytesPrimL #endif @@ -346,39 +342,38 @@ , _ListP , _SigP , _ViewP +#if MIN_VERSION_template_haskell(2,22,0) + , _TypeP + , _InvisP +#endif +#if MIN_VERSION_template_haskell(2,23,0) + , _OrP +#endif -- ** Type Prisms , _ForallT , _AppT , _SigT , _VarT , _ConT -#if MIN_VERSION_template_haskell(2,8,0) , _PromotedT -#endif , _TupleT , _UnboxedTupleT #if MIN_VERSION_template_haskell(2,12,0) , _UnboxedSumT #endif , _ArrowT -#if MIN_VERSION_template_haskell(2,10,0) , _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 , _ParensT , _WildCardT -#endif #if MIN_VERSION_template_haskell(2,15,0) , _AppKindT , _ImplicitParamT @@ -386,32 +381,41 @@ #if MIN_VERSION_template_haskell(2,16,0) , _ForallVisT #endif +#if MIN_VERSION_template_haskell(2,17,0) + , _MulArrowT +#endif +#if MIN_VERSION_template_haskell(2,19,0) + , _PromotedInfixT + , _PromotedUInfixT +#endif +#if MIN_VERSION_template_haskell(2,17,0) + -- ** Specificity Prisms + , _SpecifiedSpec + , _InferredSpec +#endif +#if MIN_VERSION_template_haskell(2,21,0) + -- ** BndrVis Prisms + , _BndrReq + , _BndrInvis +#endif -- ** TyVarBndr Prisms , _PlainTV , _KindedTV -#if MIN_VERSION_template_haskell(2,11,0) -- ** FamilyResultSig Prisms , _NoSig , _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 +#if MIN_VERSION_template_haskell(2,18,0) + , _CharTyLit #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 @@ -425,25 +429,29 @@ import Control.Lens.Getter import Control.Lens.Setter import Control.Lens.Fold +import Control.Lens.Internal.TH import Control.Lens.Iso (Iso', iso) import Control.Lens.Lens import Control.Lens.Prism import Control.Lens.Tuple import Control.Lens.Traversal -import 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') #endif +#if MIN_VERSION_template_haskell(2,18,0) +import Data.List.NonEmpty (NonEmpty) +#endif import Prelude -- | Has a 'Name' @@ -451,9 +459,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 @@ -465,33 +472,35 @@ name f (RecC n tys) = (`RecC` tys) <$> f n name f (InfixC l n r) = (\n' -> InfixC l n' r) <$> f n name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con -#if MIN_VERSION_template_haskell(2,11,0) name f (GadtC ns argTys retTy) = - (\n -> GadtC [n] argTys retTy) <$> f (head ns) + (\n -> GadtC [n] argTys retTy) <$> f (headGadtConName ns) name f (RecGadtC ns argTys retTy) = - (\n -> RecGadtC [n] argTys retTy) <$> f (head ns) -#endif + (\n -> RecGadtC [n] argTys retTy) <$> f (headGadtConName ns) +-- @template-haskell@ maintains the invariant that the list of constructor +-- @Name@s in a 'GadtC' or 'RecGadtC' will always be non-empty. +headGadtConName :: [Name] -> Name +headGadtConName conNames = + case conNames of + conName:_ -> conName + [] -> error "headGadtConName: Unexpected empty list of GADT constructor names" + instance HasName Foreign where name f (ImportF cc saf str n ty) = (\n' -> ImportF cc saf str n' ty) <$> f n name f (ExportF cc str n ty) = (\n' -> ExportF cc str n' ty) <$> f n -#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 name f (TypeFamilyHead n tvbs frs mia) = (\n' -> TypeFamilyHead n' tvbs frs mia) <$> f n instance HasName InjectivityAnn where name f (InjectivityAnn n deps) = (`InjectivityAnn` deps) <$> f n -#endif -- | Contains some amount of `Type`s inside class HasTypes t where @@ -507,31 +516,26 @@ types f (InfixC t1 n t2) = InfixC <$> _2 (types f) t1 <*> pure n <*> _2 (types f) t2 types f (ForallC vb ctx con) = ForallC vb ctx <$> types f con -#if MIN_VERSION_template_haskell(2,11,0) types f (GadtC ns argTys retTy) = GadtC ns <$> traverse (_2 (types f)) argTys <*> types f retTy types f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverse (_3 (types f)) argTys <*> types f retTy -#endif instance HasTypes Foreign where types f (ImportF cc saf str n t) = ImportF cc saf str n <$> types f t types f (ExportF cc str n t) = ExportF cc str n <$> types f t -#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 +547,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 +567,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,11 +576,7 @@ 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 -#if MIN_VERSION_template_haskell(2,11,0) typeVarsEx s f (InfixT t1 n t2) = InfixT <$> typeVarsEx s f t1 <*> pure n <*> typeVarsEx s f t2 @@ -590,7 +585,6 @@ <*> typeVarsEx s f t2 typeVarsEx s f (ParensT t) = ParensT <$> typeVarsEx s f t typeVarsEx _ _ t@WildCardT{} = pure t -#endif #if MIN_VERSION_template_haskell(2,12,0) typeVarsEx _ _ t@UnboxedSumT{} = pure t #endif @@ -603,12 +597,17 @@ 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,10,0) -instance HasTypeVars Pred where - typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts - typeVarsEx s f (EqualP l r) = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r +#if MIN_VERSION_template_haskell(2,17,0) + typeVarsEx _ _ t@MulArrowT{} = pure t #endif +#if MIN_VERSION_template_haskell(2,19,0) + typeVarsEx s f (PromotedInfixT t1 n t2) = PromotedInfixT <$> typeVarsEx s f t1 + <*> pure n + <*> typeVarsEx s f t2 + typeVarsEx s f (PromotedUInfixT t1 n t2) = PromotedUInfixT <$> typeVarsEx s f t1 + <*> pure n + <*> typeVarsEx s f t2 +#endif instance HasTypeVars Con where typeVarsEx s f (NormalC n ts) = NormalC n <$> traverseOf (traverse . _2) (typeVarsEx s f) ts @@ -617,14 +616,12 @@ where g (i, t) = (,) i <$> typeVarsEx s f t typeVarsEx s f (ForallC bs ctx c) = ForallC bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f c where s' = s `Set.union` setOf typeVars bs -#if MIN_VERSION_template_haskell(2,11,0) typeVarsEx s f (GadtC ns argTys retTy) = GadtC ns <$> traverseOf (traverse . _2) (typeVarsEx s f) argTys <*> typeVarsEx s f retTy typeVarsEx s f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverseOf (traverse . _3) (typeVarsEx s f) argTys <*> typeVarsEx s f retTy -#endif instance HasTypeVars t => HasTypeVars [t] where typeVarsEx s = traverse . typeVarsEx s @@ -656,12 +653,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,16 +661,11 @@ 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 -#if MIN_VERSION_template_haskell(2,11,0) substType m (InfixT t1 n t2) = InfixT (substType m t1) n (substType m t2) substType m (UInfixT t1 n t2) = UInfixT (substType m t1) n (substType m t2) substType m (ParensT t) = ParensT (substType m t) substType _ t@WildCardT{} = t -#endif #if MIN_VERSION_template_haskell(2,12,0) substType _ t@UnboxedSumT{} = t #endif @@ -690,72 +677,40 @@ substType m (ForallVisT bs ty) = ForallVisT bs (substType m' ty) where m' = foldrOf typeVars Map.delete m bs #endif +#if MIN_VERSION_template_haskell(2,17,0) + substType _ t@MulArrowT{} = t +#endif +#if MIN_VERSION_template_haskell(2,19,0) + substType m (PromotedInfixT t1 n t2) = PromotedInfixT (substType m t1) n (substType m t2) + substType m (PromotedUInfixT t1 n t2) = PromotedUInfixT (substType m t1) n (substType m t2) +#endif instance SubstType t => SubstType [t] where substType = map . substType -#if !MIN_VERSION_template_haskell(2,10,0) -instance SubstType Pred where - substType m (ClassP n ts) = ClassP n (substType m ts) - substType m (EqualP l r) = substType m (EqualP l r) -#endif - -- | Provides a 'Traversal' of the types of each field of a constructor. --- --- @ --- conFields :: 'Traversal'' 'Con' 'BangType' -- template-haskell-2.11+ --- conFields :: 'Traversal'' 'Con' 'StrictType' -- Earlier versions --- @ -conFields :: Traversal' Con -#if MIN_VERSION_template_haskell(2,11,0) - BangType -#else - StrictType -#endif +conFields :: Traversal' Con BangType conFields f (NormalC n fs) = NormalC n <$> traverse f fs conFields f (RecC n fs) = RecC n <$> traverse (sansVar f) fs conFields f (InfixC l n r) = InfixC <$> f l <*> pure n <*> f r conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c -#if MIN_VERSION_template_haskell(2,11,0) conFields f (GadtC ns argTys retTy) = GadtC ns <$> traverse f argTys <*> pure retTy conFields f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverse (sansVar f) argTys <*> pure retTy -#endif --- | --- @ --- sansVar :: 'Traversal'' 'VarBangType' 'BangType' -- template-haskell-2.11+ --- sansVar :: 'Traversal'' 'VarStrictType' 'StrictType' -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,11,0) -sansVar :: Traversal' VarBangType BangType -#else -sansVar :: Traversal' VarStrictType StrictType -#endif +sansVar :: Traversal' VarBangType BangType sansVar f (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t) -- | 'Traversal' of the types of the /named/ fields of a constructor. --- --- @ --- conNamedFields :: 'Traversal'' 'Con' 'VarBangType' -- template-haskell-2.11+ --- conNamedFields :: 'Traversal'' 'Con' 'VarStrictType' -- Earlier versions --- @ -conNamedFields :: Traversal' Con -#if MIN_VERSION_template_haskell(2,11,0) - VarBangType -#else - VarStrictType -#endif +conNamedFields :: Traversal' Con VarBangType conNamedFields _ c@NormalC{} = pure c conNamedFields _ c@InfixC{} = pure c conNamedFields f (RecC n fs) = RecC n <$> traverse f fs conNamedFields f (ForallC a b fs) = ForallC a b <$> conNamedFields f fs -#if MIN_VERSION_template_haskell(2,11,0) conNamedFields _ c@GadtC{} = pure c conNamedFields f (RecGadtC ns argTys retTy) = RecGadtC ns <$> traverse f argTys <*> pure retTy -#endif -- Lenses and Prisms locFileName :: Lens' Loc String @@ -840,7 +795,6 @@ g (Clause _ _ ds) = ds s (Clause x y _ ) = Clause x y -#if MIN_VERSION_template_haskell(2,11,0) injectivityAnnOutput :: Lens' InjectivityAnn Name injectivityAnnOutput = lens g s where g (InjectivityAnn o _) = o @@ -856,7 +810,7 @@ g (TypeFamilyHead n _ _ _ ) = n s (TypeFamilyHead _ tvbs rs ia) n = TypeFamilyHead n tvbs rs ia -typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndr] +typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndrVis] typeFamilyHeadTyVarBndrs = lens g s where g (TypeFamilyHead _ tvbs _ _ ) = tvbs s (TypeFamilyHead n _ rs ia) tvbs = TypeFamilyHead n tvbs rs ia @@ -880,7 +834,6 @@ bangSourceStrictness = lens g s where g (Bang _ su) = su s (Bang ss _ ) = Bang ss -#endif #if MIN_VERSION_template_haskell(2,12,0) derivClauseStrategy :: Lens' DerivClause (Maybe DerivStrategy) @@ -894,11 +847,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 @@ -906,13 +855,6 @@ remitter (ClassI x y) = Just (x, y) remitter _ = Nothing --- | --- @ --- _ClassOpI :: 'Prism'' 'Info' ('Name', 'Type', 'ParentName') -- template-haskell-2.11+ --- _ClassOpI :: 'Prism'' 'Info' ('Name', 'Type', 'ParentName', 'Fixity') -- template-haskell-2.8 through 2.10 --- _ClassOpI :: 'Prism'' 'Info' ('Name', 'Type', 'Name', 'Fixity') -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,11,0) _ClassOpI :: Prism' Info (Name, Type, ParentName) _ClassOpI = prism' reviewer remitter @@ -920,19 +862,6 @@ reviewer (x, y, z) = ClassOpI x y z 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 - reviewer (x, y, z, w) = ClassOpI x y z w - remitter (ClassOpI x y z w) = Just (x, y, z, w) - remitter _ = Nothing -#endif _TyConI :: Prism' Info Dec _TyConI @@ -942,11 +871,7 @@ remitter (TyConI x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,11,0) _FamilyI :: Prism' Info (Dec, [InstanceDec]) -#else -_FamilyI :: Prism' Info (Dec, [Dec]) -#endif _FamilyI = prism' reviewer remitter where @@ -954,11 +879,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 @@ -966,13 +887,6 @@ remitter (PrimTyConI x y z) = Just (x, y, z) remitter _ = Nothing --- | --- @ --- _DataConI :: 'Prism'' 'Info' ('Name', 'Type', 'ParentName') -- template-haskell-2.11+ --- _DataConI :: 'Prism'' 'Info' ('Name', 'Type', 'ParentName', 'Fixity') -- template-haskell-2.8 through 2.10 --- _DataConI :: 'Prism'' 'Info' ('Name', 'Type', 'Name', 'Fixity') -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,11,0) _DataConI :: Prism' Info (Name, Type, ParentName) _DataConI = prism' reviewer remitter @@ -980,26 +894,7 @@ reviewer (x, y, z) = DataConI x y z 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 - reviewer (x, y, z, w) = DataConI x y z w - remitter (DataConI x y z w) = Just (x, y, z, w) - remitter _ = Nothing -#endif --- | --- @ --- _VarI :: 'Prism'' 'Info' ('Name', 'Type', 'Maybe' 'Dec') -- template-haskell-2.11+ --- _VarI :: 'Prism'' 'Info' ('Name', 'Type', 'Maybe' 'Dec', 'Fixity') -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,11,0) _VarI :: Prism' Info (Name, Type, Maybe Dec) _VarI = prism' reviewer remitter @@ -1007,15 +902,6 @@ reviewer (x, y, z) = VarI x y z remitter (VarI x y z) = Just (x, y, z) remitter _ = Nothing -#else -_VarI :: Prism' Info (Name, Type, Maybe Dec, Fixity) -_VarI - = prism' reviewer remitter - where - reviewer (x, y, z, w) = VarI x y z w - remitter (VarI x y z w) = Just (x, y, z, w) - remitter _ = Nothing -#endif _TyVarI :: Prism' Info (Name, Type) _TyVarI @@ -1051,7 +937,7 @@ remitter (ValD x y z) = Just (x, y, z) remitter _ = Nothing -_TySynD :: Prism' Dec (Name, [TyVarBndr], Type) +_TySynD :: Prism' Dec (Name, [TyVarBndrVis], Type) _TySynD = prism' reviewer remitter where @@ -1059,7 +945,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, [TyVarBndrVis], [FunDep], [Dec]) _ClassD = prism' reviewer remitter where @@ -1067,29 +953,40 @@ remitter (ClassD x y z w u) = Just (x, y, z, w, u) remitter _ = Nothing --- | --- @ --- _InstanceD :: 'Prism'' 'Dec' ('Maybe' 'Overlap', 'Cxt', 'Type', ['Dec']) -- template-haskell-2.11+ --- _InstanceD :: 'Prism'' 'Dec' ('Cxt', 'Type', ['Dec']) -- Earlier versions --- @ -#if MIN_VERSION_template_haskell(2,11,0) _InstanceD :: Prism' Dec (Maybe Overlap, Cxt, Type, [Dec]) -#else -_InstanceD :: Prism' Dec (Cxt, Type, [Dec]) -#endif _InstanceD = prism' reviewer remitter where -#if MIN_VERSION_template_haskell(2,11,0) reviewer (x, y, z, w) = InstanceD x y z w remitter (InstanceD x y z w) = Just (x, y, z, w) -#else - reviewer (x, y, z) = InstanceD x y z - remitter (InstanceD x y z) = Just ( x, y, z) -#endif remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,11,0) +#if MIN_VERSION_template_haskell(2,22,0) +_NoNamespaceSpecifier :: Prism' NamespaceSpecifier () +_NoNamespaceSpecifier + = prism' reviewer remitter + where + reviewer () = NoNamespaceSpecifier + remitter NoNamespaceSpecifier = Just () + remitter _ = Nothing + +_TypeNamespaceSpecifier :: Prism' NamespaceSpecifier () +_TypeNamespaceSpecifier + = prism' reviewer remitter + where + reviewer () = TypeNamespaceSpecifier + remitter TypeNamespaceSpecifier = Just () + remitter _ = Nothing + +_DataNamespaceSpecifier :: Prism' NamespaceSpecifier () +_DataNamespaceSpecifier + = prism' reviewer remitter + where + reviewer () = DataNamespaceSpecifier + remitter DataNamespaceSpecifier = Just () + remitter _ = Nothing +#endif + _Overlappable :: Prism' Overlap () _Overlappable = prism' reviewer remitter where @@ -1117,7 +1014,6 @@ reviewer () = Incoherent remitter Incoherent = Just () remitter _ = Nothing -#endif _SigD :: Prism' Dec (Name, Type) _SigD @@ -1135,7 +1031,20 @@ remitter (ForeignD x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) +-- | +-- @ +-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'NamespaceSpecifier', 'Name') -- template-haskell-2.22+ +-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'Name') -- Earlier versions +-- @ +#if MIN_VERSION_template_haskell(2,22,0) +_InfixD :: Prism' Dec (Fixity, NamespaceSpecifier, Name) +_InfixD + = prism' reviewer remitter + where + reviewer (x, y, z) = InfixD x y z + remitter (InfixD x y z) = Just (x, y, z) + remitter _ = Nothing +#else _InfixD :: Prism' Dec (Fixity, Name) _InfixD = prism' reviewer remitter @@ -1167,7 +1076,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 +1084,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 +1093,6 @@ reviewer (x, y) = RoleAnnotD x y remitter (RoleAnnotD x y) = Just (x, y) remitter _ = Nothing -#endif -- | -- @ @@ -1208,7 +1107,7 @@ reviewer (x, y, z) = StandaloneDerivD x y z remitter (StandaloneDerivD x y z) = Just (x, y, z) remitter _ = Nothing -#elif MIN_VERSION_template_haskell(2,10,0) +#else _StandaloneDerivD :: Prism' Dec (Cxt, Type) _StandaloneDerivD = prism' reviewer remitter @@ -1218,7 +1117,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,10,0) _DefaultSigD :: Prism' Dec (Name, Type) _DefaultSigD = prism' reviewer remitter @@ -1226,30 +1124,28 @@ reviewer (x, y) = DefaultSigD x y remitter (DefaultSigD x y) = Just (x, y) remitter _ = Nothing -#endif # if MIN_VERSION_template_haskell(2,12,0) type DataPrism' tys cons = Prism' Dec (Cxt, Name, tys, Maybe Kind, cons, [DerivClause]) -# elif MIN_VERSION_template_haskell(2,11,0) +# else type DataPrism' tys cons = Prism' Dec (Cxt, Name, tys, Maybe Kind, cons, Cxt) # endif -- | -- @ --- _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') -- 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 reviewer (x, y, z, w, u, v) = DataInstD x y z w u v remitter (DataInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -#elif MIN_VERSION_template_haskell(2,11,0) +#else _DataInstD :: DataPrism' [Type] [Con] _DataInstD = prism' reviewer remitter @@ -1257,32 +1153,23 @@ reviewer (x, y, z, w, u, v) = DataInstD x y z w u v remitter (DataInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -#else -_DataInstD :: Prism' Dec (Cxt, Name, [Type], [Con], [Name]) -_DataInstD - = prism' reviewer remitter - where - reviewer (x, y, z, w, u) = DataInstD x y z w u - remitter (DataInstD x y z w u) = Just (x, y, z, w, u) - remitter _ = Nothing #endif -- | -- @ --- _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') -- 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 reviewer (x, y, z, w, u, v) = NewtypeInstD x y z w u v remitter (NewtypeInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -#elif MIN_VERSION_template_haskell(2,11,0) +#else _NewtypeInstD :: DataPrism' [Type] Con _NewtypeInstD = prism' reviewer remitter @@ -1290,17 +1177,8 @@ reviewer (x, y, z, w, u, v) = NewtypeInstD x y z w u v remitter (NewtypeInstD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -#else -_NewtypeInstD :: Prism' Dec (Cxt, Name, [Type], Con, [Name]) -_NewtypeInstD - = prism' reviewer remitter - where - reviewer (x, y, z, w, u) = NewtypeInstD x y z w u - remitter (NewtypeInstD x y z w u) = Just (x, y, z, w, u) - remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,11,0) _ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn]) _ClosedTypeFamilyD = prism' reviewer remitter @@ -1308,66 +1186,34 @@ 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]) -_ClosedTypeFamilyD - = prism' reviewer remitter - where - reviewer (x, y, z, w) = ClosedTypeFamilyD x y z w - remitter (ClosedTypeFamilyD x y z w) = Just (x, y, z, w) - remitter _ = Nothing -#endif -- | -- @ --- _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') -- Earlier versions -- @ -#if MIN_VERSION_template_haskell(2,11,0) -_DataD :: DataPrism' [TyVarBndr] [Con] +_DataD :: DataPrism' [TyVarBndrVis] [Con] _DataD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = DataD x y z w u v remitter (DataD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -#else -_DataD :: Prism' Dec (Cxt, Name, [TyVarBndr], [Con], [Name]) -_DataD - = prism' reviewer remitter - where - reviewer (x, y, z, w, u) = DataD x y z w u - remitter (DataD x y z w u) = Just (x, y, z, w, u) - remitter _ = Nothing -#endif -- | -- @ --- _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') -- Earlier versions -- @ -#if MIN_VERSION_template_haskell(2,11,0) -_NewtypeD :: DataPrism' [TyVarBndr] Con +_NewtypeD :: DataPrism' [TyVarBndrVis] Con _NewtypeD = prism' reviewer remitter where reviewer (x, y, z, w, u, v) = NewtypeD x y z w u v remitter (NewtypeD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -#else -_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndr], Con, [Name]) -_NewtypeD - = prism' reviewer remitter - where - reviewer (x, y, z, w, u) = NewtypeD x y z w u - remitter (NewtypeD x y z w u) = Just (x, y, z, w, u) - remitter _ = Nothing -#endif -#if MIN_VERSION_template_haskell(2,11,0) -_DataFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind) +_DataFamilyD :: Prism' Dec (Name, [TyVarBndrVis], Maybe Kind) _DataFamilyD = prism' reviewer remitter where @@ -1382,15 +1228,6 @@ reviewer = OpenTypeFamilyD remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing -#else -_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndr], Maybe Kind) -_FamilyD - = prism' reviewer remitter - where - reviewer (x, y, z, w) = FamilyD x y z w - remitter (FamilyD x y z w) = Just (x, y, z, w) - remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,12,0) _PatSynD :: Prism' Dec (Name, PatSynArgs, PatSynDir, Pat) @@ -1420,6 +1257,26 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0) +_DefaultD :: Prism' Dec [Type] +_DefaultD + = prism' reviewer remitter + where + reviewer = DefaultD + remitter (DefaultD x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,20,0) +_TypeDataD :: Prism' Dec (Name, [TyVarBndrVis], Maybe Kind, [Con]) +_TypeDataD + = prism' reviewer remitter + where + reviewer (x, y, z, u) = TypeDataD x y z u + remitter (TypeDataD x y z u) = Just (x, y, z, u) + remitter _ = Nothing +#endif + #if MIN_VERSION_template_haskell(2,12,0) _Unidir :: Prism' PatSynDir () _Unidir @@ -1470,19 +1327,7 @@ remitter _ = Nothing #endif --- | --- @ --- _NormalC :: 'Prism'' 'Con' ('Name', ['BangType']) -- template-haskell-2.11+ --- _NormalC :: 'Prism'' 'Con' ('Name', ['StrictType']) -- Earlier versions --- @ -_NormalC :: - Prism' Con ( Name -#if MIN_VERSION_template_haskell(2,11,0) - , [BangType] -#else - , [StrictType] -#endif - ) +_NormalC :: Prism' Con (Name, [BangType]) _NormalC = prism' reviewer remitter where @@ -1490,19 +1335,7 @@ remitter (NormalC x y) = Just (x, y) remitter _ = Nothing --- | --- @ --- _RecC :: 'Prism'' 'Con' ('Name', ['VarBangType']) -- template-haskell-2.11+ --- _RecC :: 'Prism'' 'Con' ('Name', ['VarStrictType']) -- Earlier versions --- @ -_RecC :: - Prism' Con ( Name -#if MIN_VERSION_template_haskell(2,11,0) - , [VarBangType] -#else - , [VarStrictType] -#endif - ) +_RecC :: Prism' Con (Name, [VarBangType]) _RecC = prism' reviewer remitter where @@ -1510,18 +1343,7 @@ remitter (RecC x y) = Just (x, y) remitter _ = Nothing --- | --- @ --- _InfixC :: 'Prism'' 'Con' ('BangType', 'Name', 'BangType') -- template-haskell-2.11+ --- _InfixC :: 'Prism'' 'Con' ('StrictType', 'Name', 'StrictType') -- Earlier versions --- @ -_InfixC :: - Prism' Con -#if MIN_VERSION_template_haskell(2,11,0) - (BangType, Name, BangType ) -#else - (StrictType, Name, StrictType) -#endif +_InfixC :: Prism' Con (BangType, Name, BangType ) _InfixC = prism' reviewer remitter where @@ -1529,7 +1351,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 @@ -1537,7 +1359,6 @@ remitter (ForallC x y z) = Just (x, y, z) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,11,0) _GadtC :: Prism' Con ([Name], [BangType], Type) _GadtC = prism' reviewer remitter @@ -1553,9 +1374,7 @@ reviewer (x, y, z) = RecGadtC x y z remitter (RecGadtC x y z) = Just (x, y, z) remitter _ = Nothing -#endif -#if MIN_VERSION_template_haskell(2,11,0) _NoSourceUnpackedness :: Prism' SourceUnpackedness () _NoSourceUnpackedness = prism' reviewer remitter @@ -1627,32 +1446,7 @@ reviewer () = DecidedUnpack remitter DecidedUnpack = Just () remitter _ = Nothing -#else -_IsStrict :: Prism' Strict () -_IsStrict - = prism' reviewer remitter - where - reviewer () = IsStrict - remitter IsStrict = Just () - remitter _ = Nothing -_NotStrict :: Prism' Strict () -_NotStrict - = prism' reviewer remitter - where - reviewer () = NotStrict - remitter NotStrict = Just () - remitter _ = Nothing - -_Unpacked :: Prism' Strict () -_Unpacked - = prism' reviewer remitter - where - reviewer () = Unpacked - remitter Unpacked = Just () - remitter _ = Nothing -#endif - _ImportF :: Prism' Foreign (Callconv, Safety, String, Name, Type) _ImportF = prism' reviewer remitter @@ -1685,7 +1479,6 @@ remitter StdCall = Just () remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,10,0) _CApi :: Prism' Callconv () _CApi = prism' reviewer remitter @@ -1709,7 +1502,6 @@ reviewer () = JavaScript remitter JavaScript = Just () remitter _ = Nothing -#endif _Unsafe :: Prism' Safety () _Unsafe @@ -1735,12 +1527,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 +1534,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 +1542,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 +1555,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 +1576,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _AnnP :: Prism' Pragma (AnnTarget, Exp) _AnnP = prism' reviewer remitter @@ -1823,9 +1583,7 @@ 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) _LineP = prism' reviewer remitter @@ -1833,7 +1591,6 @@ reviewer (x, y) = LineP x y remitter (LineP x y) = Just (x, y) remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,12,0) _CompleteP :: Prism' Pragma ([Name], Maybe Name) @@ -1845,6 +1602,36 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0) +_OpaqueP :: Prism' Pragma Name +_OpaqueP + = prism' reviewer remitter + where + reviewer = OpaqueP + remitter (OpaqueP x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,22,0) +_SCCP :: Prism' Pragma (Name, Maybe String) +_SCCP + = prism' reviewer remitter + where + reviewer (x, y) = SCCP x y + remitter (SCCP x y) = Just (x, y) + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,24,0) +_SpecialiseEP :: Prism' Pragma (Maybe [TyVarBndr ()], [RuleBndr], Exp, Maybe Inline, Phases) +_SpecialiseEP + = prism' reviewer remitter + where + reviewer (x, y, z, w, u) = SpecialiseEP x y z w u + remitter (SpecialiseEP x y z w u) = Just (x, y, z, w, u) + remitter _ = Nothing +#endif + _NoInline :: Prism' Inline () _NoInline = prism' reviewer remitter @@ -1924,9 +1711,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 +1735,6 @@ reviewer = ValueAnnotation remitter (ValueAnnotation x) = Just x remitter _ = Nothing -#endif _FunDep :: Iso' FunDep ([Name], [Name]) _FunDep @@ -1994,7 +1778,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 +1888,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 +1895,6 @@ reviewer = LamCaseE remitter (LamCaseE x) = Just x remitter _ = Nothing -#endif -- | -- @ @@ -2166,7 +1948,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 +1955,6 @@ reviewer = MultiIfE remitter (MultiIfE x) = Just x remitter _ = Nothing -#endif _LetE :: Prism' Exp ([Dec], Exp) _LetE @@ -2192,6 +1972,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 +1993,7 @@ reviewer = DoE remitter (DoE x) = Just x remitter _ = Nothing +# endif _CompE :: Prism' Exp [Stmt] _CompE @@ -2248,7 +2043,6 @@ remitter (RecUpdE x y) = Just (x, y) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,10,0) _StaticE :: Prism' Exp Exp _StaticE = prism' reviewer remitter @@ -2256,9 +2050,7 @@ reviewer = StaticE remitter (StaticE x) = Just x remitter _ = Nothing -#endif -#if MIN_VERSION_template_haskell(2,11,0) _UnboundVarE :: Prism' Exp Name _UnboundVarE = prism' reviewer remitter @@ -2266,7 +2058,6 @@ reviewer = UnboundVarE remitter (UnboundVarE x) = Just x remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,13,0) _LabelE :: Prism' Exp String @@ -2279,6 +2070,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 +2091,7 @@ reviewer = MDoE remitter (MDoE x) = Just x remitter _ = Nothing +# endif _ImplicitParamVarE :: Prism' Exp String _ImplicitParamVarE @@ -2296,6 +2102,88 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,18,0) +_GetFieldE :: Prism' Exp (Exp, String) +_GetFieldE + = prism' reviewer remitter + where + reviewer (x, y) = GetFieldE x y + remitter (GetFieldE x y) = Just (x, y) + remitter _ = Nothing + +_ProjectionE :: Prism' Exp (NonEmpty String) +_ProjectionE + = prism' reviewer remitter + where + reviewer = ProjectionE + remitter (ProjectionE x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,19,0) +_LamCasesE :: Prism' Exp [Clause] +_LamCasesE + = prism' reviewer remitter + where + reviewer = LamCasesE + remitter (LamCasesE x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,21,0) +_TypedBracketE :: Prism' Exp Exp +_TypedBracketE + = prism' reviewer remitter + where + reviewer = TypedBracketE + remitter (TypedBracketE x) = Just x + remitter _ = Nothing + +_TypedSpliceE :: Prism' Exp Exp +_TypedSpliceE + = prism' reviewer remitter + where + reviewer = TypedSpliceE + remitter (TypedSpliceE x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,22,0) +_TypeE :: Prism' Exp Type +_TypeE + = prism' reviewer remitter + where + reviewer = TypeE + remitter (TypeE x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,23,0) +_ForallE :: Prism' Exp ([TyVarBndr Specificity], Exp) +_ForallE + = prism' reviewer remitter + where + reviewer (x, y) = ForallE x y + remitter (ForallE x y) = Just (x, y) + remitter _ = Nothing + +_ForallVisE :: Prism' Exp ([TyVarBndr ()], Exp) +_ForallVisE + = prism' reviewer remitter + where + reviewer (x, y) = ForallVisE x y + remitter (ForallVisE x y) = Just (x, y) + remitter _ = Nothing + +_ConstrainedE :: Prism' Exp ([Exp], Exp) +_ConstrainedE + = prism' reviewer remitter + where + reviewer (x, y) = ConstrainedE x y + remitter (ConstrainedE x y) = Just (x, y) + remitter _ = Nothing +#endif + _GuardedB :: Prism' Body [(Guard, Exp)] _GuardedB = prism' reviewer remitter @@ -2466,7 +2354,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,17 +2361,7 @@ 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 _CharPrimL = prism' reviewer remitter @@ -2492,7 +2369,6 @@ reviewer = CharPrimL remitter (CharPrimL x) = Just x remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,16,0) _BytesPrimL :: Prism' Lit Bytes @@ -2546,6 +2422,20 @@ remitter _ = Nothing #endif +-- | +-- @ +-- _ConP :: 'Prism'' 'Pat' ('Name', ['Type'], ['Pat']) -- template-haskell-2.18+ +-- _ConP :: 'Prism'' 'Pat' ('Name', ['Pat']) -- Earlier versions +-- @ +#if MIN_VERSION_template_haskell(2,18,0) +_ConP :: Prism' Pat (Name, [Type], [Pat]) +_ConP + = prism' reviewer remitter + where + reviewer (x, y, z) = ConP x y z + remitter (ConP x y z) = Just (x, y, z) + remitter _ = Nothing +#else _ConP :: Prism' Pat (Name, [Pat]) _ConP = prism' reviewer remitter @@ -2553,6 +2443,7 @@ reviewer (x, y) = ConP x y remitter (ConP x y) = Just (x, y) remitter _ = Nothing +#endif _InfixP :: Prism' Pat (Pat, Name, Pat) _InfixP @@ -2642,7 +2533,35 @@ remitter (ViewP x y) = Just (x, y) remitter _ = Nothing -_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type) +#if MIN_VERSION_template_haskell(2,22,0) +_TypeP :: Prism' Pat Type +_TypeP + = prism' reviewer remitter + where + reviewer = TypeP + remitter (TypeP x) = Just x + remitter _ = Nothing + +_InvisP :: Prism' Pat Type +_InvisP + = prism' reviewer remitter + where + reviewer = InvisP + remitter (InvisP x) = Just x + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,23,0) +_OrP :: Prism' Pat (NonEmpty Pat) +_OrP + = prism' reviewer remitter + where + reviewer = OrP + remitter (OrP x) = Just x + remitter _ = Nothing +#endif + +_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter where @@ -2682,7 +2601,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 +2608,6 @@ reviewer = PromotedT remitter (PromotedT x) = Just x remitter _ = Nothing -#endif _TupleT :: Prism' Type Int _TupleT @@ -2726,7 +2643,6 @@ remitter ArrowT = Just () remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,10,0) _EqualityT :: Prism' Type () _EqualityT = prism' reviewer remitter @@ -2734,7 +2650,6 @@ reviewer () = EqualityT remitter EqualityT = Just () remitter _ = Nothing -#endif _ListT :: Prism' Type () _ListT @@ -2744,7 +2659,6 @@ remitter ListT = Just () remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PromotedTupleT :: Prism' Type Int _PromotedTupleT = prism' reviewer remitter @@ -2792,9 +2706,7 @@ reviewer = LitT remitter (LitT x) = Just x remitter _ = Nothing -#endif -#if MIN_VERSION_template_haskell(2,11,0) _InfixT :: Prism' Type (Type, Name, Type) _InfixT = prism' reviewer remitter @@ -2826,7 +2738,6 @@ reviewer () = WildCardT remitter WildCardT = Just () remitter _ = Nothing -#endif #if MIN_VERSION_template_haskell(2,15,0) _AppKindT :: Prism' Type (Type, Kind) @@ -2847,7 +2758,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 +2767,84 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,17,0) +_MulArrowT :: Prism' Type () +_MulArrowT + = prism' reviewer remitter + where + reviewer () = MulArrowT + remitter MulArrowT = Just () + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,19,0) +_PromotedInfixT :: Prism' Type (Type, Name, Type) +_PromotedInfixT + = prism' reviewer remitter + where + reviewer (x, y, z) = PromotedInfixT x y z + remitter (PromotedInfixT x y z) = Just (x, y, z) + remitter _ = Nothing + +_PromotedUInfixT :: Prism' Type (Type, Name, Type) +_PromotedUInfixT + = prism' reviewer remitter + where + reviewer (x, y, z) = PromotedUInfixT x y z + remitter (PromotedUInfixT x y z) = Just (x, y, z) + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,17,0) +_SpecifiedSpec :: Prism' Specificity () +_SpecifiedSpec + = prism' reviewer remitter + where + reviewer () = SpecifiedSpec + remitter SpecifiedSpec = Just () + remitter _ = Nothing + +_InferredSpec :: Prism' Specificity () +_InferredSpec + = prism' reviewer remitter + where + reviewer () = InferredSpec + remitter InferredSpec = Just () + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,21,0) +_BndrReq :: Prism' BndrVis () +_BndrReq + = prism' reviewer remitter + where + reviewer () = BndrReq + remitter BndrReq = Just () + remitter _ = Nothing + +_BndrInvis :: Prism' BndrVis () +_BndrInvis + = prism' reviewer remitter + where + reviewer () = BndrInvis + remitter BndrInvis = Just () + remitter _ = Nothing +#endif + +-- | +-- @ +-- _PlainTV :: 'Prism'' ('TyVarBndr' flag) ('Name', flag) -- template-haskell-2.17+ +-- _PlainTV :: 'Prism'' 'TyVarBndr' 'Name' -- Earlier versions +-- @ +#if MIN_VERSION_template_haskell(2,17,0) +_PlainTV :: Prism' (TyVarBndr flag) (Name, flag) +_PlainTV + = prism' reviewer remitter + where + reviewer (x, y) = PlainTV x y + remitter (PlainTV x y) = Just (x, y) + remitter _ = Nothing +#else _PlainTV :: Prism' TyVarBndr Name _PlainTV = prism' reviewer remitter @@ -2863,7 +2852,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,8 +2875,8 @@ 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 () _NoSig = prism' reviewer remitter @@ -2889,16 +2893,14 @@ remitter (KindSig x) = Just x remitter _ = Nothing -_TyVarSig :: Prism' FamilyResultSig TyVarBndr +_TyVarSig :: Prism' FamilyResultSig TyVarBndrUnit _TyVarSig = prism' reviewer remitter where reviewer = TyVarSig remitter (TyVarSig x) = Just x remitter _ = Nothing -#endif -#if MIN_VERSION_template_haskell(2,8,0) _NumTyLit :: Prism' TyLit Integer _NumTyLit = prism' reviewer remitter @@ -2914,27 +2916,17 @@ reviewer = StrTyLit remitter (StrTyLit x) = Just x remitter _ = Nothing -#endif -#if !MIN_VERSION_template_haskell(2,10,0) -_ClassP :: Prism' Pred (Name, [Type]) -_ClassP - = prism' reviewer remitter - where - reviewer (x, y) = ClassP x y - remitter (ClassP x y) = Just (x, y) - remitter _ = Nothing - -_EqualP :: Prism' Pred (Type, Type) -_EqualP +#if MIN_VERSION_template_haskell(2,18,0) +_CharTyLit :: Prism' TyLit Char +_CharTyLit = prism' reviewer remitter where - reviewer (x, y) = EqualP x y - remitter (EqualP x y) = Just (x, y) + reviewer = CharTyLit + remitter (CharTyLit x) = Just x remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _NominalR :: Prism' Role () _NominalR = prism' reviewer remitter @@ -2966,7 +2958,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 @@ -2,10 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#endif -------------------------------------------------------------------------------- -- | -- Module : Numeric.Lens @@ -30,9 +28,7 @@ , dividing , exponentiating , negated -#if __GLASGOW_HASKELL__ >= 710 , pattern Integral -#endif ) where import Control.Lens @@ -43,12 +39,13 @@ -- $setup -- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens -- >>> import Data.Monoid (Sum(..)) --- | This 'Prism' can be used to model the fact that every 'Integral' +-- | This t'Prism' can be used to model the fact that every t'Integral' -- type is a subset of 'Integer'. -- --- Embedding through the 'Prism' only succeeds if the 'Integer' would pass +-- Embedding through the t'Prism' only succeeds if the 'Integer' would pass -- through unmodified when re-extracted. integral :: (Integral a, Integral b) => Prism Integer Integer a b integral = prism toInteger $ \ i -> let a = fromInteger i in @@ -56,10 +53,9 @@ then Right a else Left i -#if __GLASGOW_HASKELL__ >= 710 +pattern Integral :: Integral a => a -> Integer pattern Integral a <- (preview integral -> Just a) where Integral a = review integral a -#endif -- | A prism that shows and reads integers in base-2 through base-36 -- diff --git a/src/Numeric/Natural/Lens.hs b/src/Numeric/Natural/Lens.hs --- a/src/Numeric/Natural/Lens.hs +++ b/src/Numeric/Natural/Lens.hs @@ -1,10 +1,7 @@ -{-# language CPP #-} {-# language RankNTypes #-} {-# language PatternGuards #-} -#if __GLASGOW_HASKELL__ >= 710 {-# language ViewPatterns #-} {-# language PatternSynonyms #-} -#endif -------------------------------------------------------------------------------- -- | -- Module : Numeric.Natural.Lens @@ -20,11 +17,9 @@ ( _Pair , _Sum , _Naturals -#if __GLASGOW_HASKELL__ >= 710 , pattern Pair , pattern Sum , pattern Naturals -#endif ) where import Control.Lens @@ -65,8 +60,6 @@ yon [] = 0 yon (x:xs) = 1 + review _Pair (x, yon xs) -#if __GLASGOW_HASKELL__ >= 710 - -- | -- interleaves the bits of two natural numbers pattern Pair :: Natural -> Natural -> Natural @@ -90,4 +83,3 @@ pattern Naturals :: [Natural] -> Natural pattern Naturals xs <- (view _Naturals -> xs) where Naturals xs = review _Naturals xs -#endif diff --git a/src/System/Exit/Lens.hs b/src/System/Exit/Lens.hs --- a/src/System/Exit/Lens.hs +++ b/src/System/Exit/Lens.hs @@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#endif ----------------------------------------------------------------------------- -- | @@ -22,10 +19,8 @@ ( AsExitCode(..) , _ExitFailure , _ExitSuccess -#if __GLASGOW_HASKELL__ >= 710 , pattern ExitFailure_ , pattern ExitSuccess_ -#endif ) where import Prelude () @@ -73,10 +68,10 @@ seta t = Left (pure t) {-# INLINE _ExitFailure #-} -#if __GLASGOW_HASKELL__ >= 710 +pattern ExitSuccess_ :: AsExitCode s => s pattern ExitSuccess_ <- (has _ExitSuccess -> True) where ExitSuccess_ = review _ExitSuccess () +pattern ExitFailure_ :: AsExitCode s => Int -> s pattern ExitFailure_ a <- (preview _ExitFailure -> Just a) where ExitFailure_ a = review _ExitFailure a -#endif 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), @@ -58,10 +61,10 @@ -- True -- -- @ --- ('~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a --- ('~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a --- ('~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a --- ('~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a +-- ('~') :: t'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a +-- ('~') :: t'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a +-- ('~') :: t'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a +-- ('~') :: t'Traversal' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- @ (~) :: ASetter s t FilePath FilePath -> FilePath -> s -> t l ~ n = over l ( n) @@ -84,7 +87,7 @@ {-# INLINE (=) #-} --- | Add a path onto the end of the target of a 'Lens' and return the result +-- | Add a path onto the end of the target of a t'Lens' and return the result -- -- When you do not need the result of the operation, ('~') is more flexible. (<~) :: LensLike ((,)FilePath) s a FilePath FilePath -> FilePath -> s -> (FilePath, a) @@ -92,7 +95,7 @@ {-# INLINE (<~) #-} --- | Add a path onto the end of the target of a 'Lens' into +-- | Add a path onto the end of the target of a t'Lens' into -- your monad's state and return the result. -- -- When you do not need the result of the operation, ('=') is more flexible. @@ -101,7 +104,7 @@ {-# INLINE (<=) #-} --- | Add a path onto the end of the target of a 'Lens' and return the original +-- | Add a path onto the end of the target of a t'Lens' and return the original -- value. -- -- When you do not need the original value, ('~') is more flexible. @@ -109,7 +112,7 @@ l <<~ b = l $ \a -> (a, a b) {-# INLINE (<<~) #-} --- | Add a path onto the end of a target of a 'Lens' into your monad's state +-- | Add a path onto the end of a target of a t'Lens' into your monad's state -- and return the old value. -- -- When you do not need the result of the operation, ('=') is more flexible. @@ -123,10 +126,10 @@ -- ("hello.txt","world.txt") -- -- @ --- ('<.>~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a --- ('<.>~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a --- ('<.>~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a --- ('<.>~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'String' -> s -> a +-- ('<.>~') :: t'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a +-- ('<.>~') :: t'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a +-- ('<.>~') :: t'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a +-- ('<.>~') :: t'Traversal' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- @ (<.>~) :: ASetter s a FilePath FilePath -> String -> s -> a l <.>~ n = over l (<.> n) @@ -147,7 +150,7 @@ l <.>= b = State.modify (l <.>~ b) {-# INLINE (<.>=) #-} --- | Add an extension onto the end of the target of a 'Lens' and return the result +-- | Add an extension onto the end of the target of a t'Lens' and return the result -- -- >>> _1 <<.>~ "txt" $ ("hello","world") -- ("hello.txt",("hello.txt","world")) @@ -158,7 +161,7 @@ {-# INLINE (<<.>~) #-} --- | Add an extension onto the end of the target of a 'Lens' into +-- | Add an extension onto the end of the target of a t'Lens' into -- your monad's state and return the result. -- -- >>> evalState (_1 <<.>= "txt") ("hello","world") @@ -169,7 +172,7 @@ l <<.>= r = l <%= (<.> r) {-# INLINE (<<.>=) #-} --- | Add an extension onto the end of the target of a 'Lens' but +-- | Add an extension onto the end of the target of a t'Lens' but -- return the old value -- -- >>> _1 <<<.>~ "txt" $ ("hello","world") @@ -180,7 +183,7 @@ l <<<.>~ b = l $ \a -> (a, a <.> b) {-# INLINE (<<<.>~) #-} --- | Add an extension onto the end of the target of a 'Lens' into your monad's +-- | Add an extension onto the end of the target of a t'Lens' into your monad's -- state and return the old value. -- -- >>> runState (_1 <<<.>= "txt") ("hello","world") @@ -191,9 +194,9 @@ l <<<.>= b = l %%= \a -> (a, a <.> b) {-# INLINE (<<<.>=) #-} --- | A 'Lens' for reading and writing to the basename +-- | A t'Lens' for reading and writing to the basename -- --- Note: This is 'not' a legal 'Lens' unless the outer 'FilePath' has both a directory +-- Note: This is /not/ a legal t'Lens' unless the outer 'FilePath' has both a directory -- and filename component and the generated basenames are not null and contain no directory -- separators. -- @@ -204,9 +207,9 @@ {-# INLINE basename #-} --- | A 'Lens' for reading and writing to the directory +-- | A t'Lens' for reading and writing to the directory -- --- Note: this is /not/ a legal 'Lens' unless the outer 'FilePath' already has a directory component, +-- Note: this is /not/ a legal t'Lens' unless the outer 'FilePath' already has a directory component, -- and generated directories are not null. -- -- >>> (("long" "path" "name.txt") ^. directory) == "long" "path" @@ -216,9 +219,9 @@ {-# INLINE directory #-} --- | A 'Lens' for reading and writing to the extension +-- | A t'Lens' for reading and writing to the extension -- --- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated +-- Note: This is /not/ a legal t'Lens', unless you are careful to ensure that generated -- extension 'FilePath' components are either null or start with 'System.FilePath.extSeparator' -- and do not contain any internal 'System.FilePath.extSeparator's. -- @@ -231,9 +234,9 @@ {-# INLINE extension #-} --- | A 'Lens' for reading and writing to the full filename +-- | A t'Lens' for reading and writing to the full filename -- --- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated +-- Note: This is /not/ a legal t'Lens', unless you are careful to ensure that generated -- filename 'FilePath' components are not null and do not contain any -- elements of 'System.FilePath.pathSeparators's. -- diff --git a/tests/BigRecord.hs b/tests/BigRecord.hs new file mode 100644 --- /dev/null +++ b/tests/BigRecord.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} + +module BigRecord where + +import Control.Lens + +data Big = Big + { _a0 :: Int , _a1 :: Int , _a2 :: Int , _a3 :: Int , _a4 :: Int , _a5 :: Int , _a6 :: Int , _a7 :: Int + , _a8 :: Int , _a9 :: Int , _a10 :: Int , _a11 :: Int , _a12 :: Int , _a13 :: Int , _a14 :: Int , _a15 :: Int + , _a16 :: Int , _a17 :: Int , _a18 :: Int , _a19 :: Int , _a20 :: Int , _a21 :: Int , _a22 :: Int , _a23 :: Int + , _a24 :: Int , _a25 :: Int , _a26 :: Int , _a27 :: Int , _a28 :: Int , _a29 :: Int , _a30 :: Int , _a31 :: Int + , _a32 :: Int , _a33 :: Int , _a34 :: Int , _a35 :: Int , _a36 :: Int , _a37 :: Int , _a38 :: Int , _a39 :: Int + , _a40 :: Int , _a41 :: Int , _a42 :: Int , _a43 :: Int , _a44 :: Int , _a45 :: Int , _a46 :: Int , _a47 :: Int + , _a48 :: Int , _a49 :: Int , _a50 :: Int , _a51 :: Int , _a52 :: Int , _a53 :: Int , _a54 :: Int , _a55 :: Int + , _a56 :: Int , _a57 :: Int , _a58 :: Int , _a59 :: Int , _a60 :: Int , _a61 :: Int , _a62 :: Int , _a63 :: Int + , _a64 :: Int , _a65 :: Int , _a66 :: Int , _a67 :: Int , _a68 :: Int , _a69 :: Int , _a70 :: Int , _a71 :: Int + , _a72 :: Int , _a73 :: Int , _a74 :: Int , _a75 :: Int , _a76 :: Int , _a77 :: Int , _a78 :: Int , _a79 :: Int + , _a80 :: Int , _a81 :: Int , _a82 :: Int , _a83 :: Int , _a84 :: Int , _a85 :: Int , _a86 :: Int , _a87 :: Int + , _a88 :: Int , _a89 :: Int , _a90 :: Int , _a91 :: Int , _a92 :: Int , _a93 :: Int , _a94 :: Int , _a95 :: Int + , _a96 :: Int , _a97 :: Int , _a98 :: Int , _a99 :: Int + } + +data Bigger = Bigger + { _b0 :: Int , _b1 :: Int , _b2 :: Int , _b3 :: Int , _b4 :: Int , _b5 :: Int , _b6 :: Int , _b7 :: Int + , _b8 :: Int , _b9 :: Int , _b10 :: Int , _b11 :: Int , _b12 :: Int , _b13 :: Int , _b14 :: Int , _b15 :: Int + , _b16 :: Int , _b17 :: Int , _b18 :: Int , _b19 :: Int , _b20 :: Int , _b21 :: Int , _b22 :: Int , _b23 :: Int + , _b24 :: Int , _b25 :: Int , _b26 :: Int , _b27 :: Int , _b28 :: Int , _b29 :: Int , _b30 :: Int , _b31 :: Int + , _b32 :: Int , _b33 :: Int , _b34 :: Int , _b35 :: Int , _b36 :: Int , _b37 :: Int , _b38 :: Int , _b39 :: Int + , _b40 :: Int , _b41 :: Int , _b42 :: Int , _b43 :: Int , _b44 :: Int , _b45 :: Int , _b46 :: Int , _b47 :: Int + , _b48 :: Int , _b49 :: Int , _b50 :: Int , _b51 :: Int , _b52 :: Int , _b53 :: Int , _b54 :: Int , _b55 :: Int + , _b56 :: Int , _b57 :: Int , _b58 :: Int , _b59 :: Int , _b60 :: Int , _b61 :: Int , _b62 :: Int , _b63 :: Int + , _b64 :: Int , _b65 :: Int , _b66 :: Int , _b67 :: Int , _b68 :: Int , _b69 :: Int , _b70 :: Int , _b71 :: Int + , _b72 :: Int , _b73 :: Int , _b74 :: Int , _b75 :: Int , _b76 :: Int , _b77 :: Int , _b78 :: Int , _b79 :: Int + , _b80 :: Int , _b81 :: Int , _b82 :: Int , _b83 :: Int , _b84 :: Int , _b85 :: Int , _b86 :: Int , _b87 :: Int + , _b88 :: Int , _b89 :: Int , _b90 :: Int , _b91 :: Int , _b92 :: Int , _b93 :: Int , _b94 :: Int , _b95 :: Int + , _b96 :: Int , _b97 :: Int , _b98 :: Int , _b99 :: Int , _b100 :: Int , _b101 :: Int , _b102 :: Int , _b103 :: Int + , _b104 :: Int , _b105 :: Int , _b106 :: Int , _b107 :: Int , _b108 :: Int , _b109 :: Int , _b110 :: Int , _b111 :: Int + , _b112 :: Int , _b113 :: Int , _b114 :: Int , _b115 :: Int , _b116 :: Int , _b117 :: Int , _b118 :: Int , _b119 :: Int + , _b120 :: Int , _b121 :: Int , _b122 :: Int , _b123 :: Int , _b124 :: Int , _b125 :: Int , _b126 :: Int , _b127 :: Int + , _b128 :: Int , _b129 :: Int , _b130 :: Int , _b131 :: Int , _b132 :: Int , _b133 :: Int , _b134 :: Int , _b135 :: Int + , _b136 :: Int , _b137 :: Int , _b138 :: Int , _b139 :: Int , _b140 :: Int , _b141 :: Int , _b142 :: Int , _b143 :: Int + , _b144 :: Int , _b145 :: Int , _b146 :: Int , _b147 :: Int , _b148 :: Int , _b149 :: Int , _b150 :: Int , _b151 :: Int + , _b152 :: Int , _b153 :: Int , _b154 :: Int , _b155 :: Int , _b156 :: Int , _b157 :: Int , _b158 :: Int , _b159 :: Int + , _b160 :: Int , _b161 :: Int , _b162 :: Int , _b163 :: Int , _b164 :: Int , _b165 :: Int , _b166 :: Int , _b167 :: Int + , _b168 :: Int , _b169 :: Int , _b170 :: Int , _b171 :: Int , _b172 :: Int , _b173 :: Int , _b174 :: Int , _b175 :: Int + , _b176 :: Int , _b177 :: Int , _b178 :: Int , _b179 :: Int , _b180 :: Int , _b181 :: Int , _b182 :: Int , _b183 :: Int + , _b184 :: Int , _b185 :: Int , _b186 :: Int , _b187 :: Int , _b188 :: Int , _b189 :: Int , _b190 :: Int , _b191 :: Int + , _b192 :: Int , _b193 :: Int , _b194 :: Int , _b195 :: Int , _b196 :: Int , _b197 :: Int , _b198 :: Int , _b199 :: Int + , _b200 :: Int , _b201 :: Int , _b202 :: Int , _b203 :: Int , _b204 :: Int , _b205 :: Int , _b206 :: Int , _b207 :: Int + , _b208 :: Int , _b209 :: Int , _b210 :: Int , _b211 :: Int , _b212 :: Int , _b213 :: Int , _b214 :: Int , _b215 :: Int + , _b216 :: Int , _b217 :: Int , _b218 :: Int , _b219 :: Int , _b220 :: Int , _b221 :: Int , _b222 :: Int , _b223 :: Int + , _b224 :: Int , _b225 :: Int , _b226 :: Int , _b227 :: Int , _b228 :: Int , _b229 :: Int , _b230 :: Int , _b231 :: Int + , _b232 :: Int , _b233 :: Int , _b234 :: Int , _b235 :: Int , _b236 :: Int , _b237 :: Int , _b238 :: Int , _b239 :: Int + , _b240 :: Int , _b241 :: Int , _b242 :: Int , _b243 :: Int , _b244 :: Int , _b245 :: Int , _b246 :: Int , _b247 :: Int + , _b248 :: Int , _b249 :: Int , _b250 :: Int , _b251 :: Int , _b252 :: Int , _b253 :: Int , _b254 :: Int , _b255 :: Int + , _b256 :: Int , _b257 :: Int , _b258 :: Int , _b259 :: Int , _b260 :: Int , _b261 :: Int , _b262 :: Int , _b263 :: Int + , _b264 :: Int , _b265 :: Int , _b266 :: Int , _b267 :: Int , _b268 :: Int , _b269 :: Int , _b270 :: Int , _b271 :: Int + , _b272 :: Int , _b273 :: Int , _b274 :: Int , _b275 :: Int , _b276 :: Int , _b277 :: Int , _b278 :: Int , _b279 :: Int + , _b280 :: Int , _b281 :: Int , _b282 :: Int , _b283 :: Int , _b284 :: Int , _b285 :: Int , _b286 :: Int , _b287 :: Int + , _b288 :: Int , _b289 :: Int , _b290 :: Int , _b291 :: Int , _b292 :: Int , _b293 :: Int , _b294 :: Int , _b295 :: Int + , _b296 :: Int , _b297 :: Int , _b298 :: Int , _b299 :: Int + } + +makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Big +makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Bigger diff --git a/tests/T1024.hs b/tests/T1024.hs new file mode 100644 --- /dev/null +++ b/tests/T1024.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Test 'makeFieldsId', which requires NoFieldSelectors and +-- DuplicateRecordFields. This test consequently only works on GHC >= 9.2. +module T1024 where + +import Control.Lens + +data Taco = Taco + { hardShell :: Bool + , sauce :: Int + , filling :: String + } +data Burrito = Burrito + { sauce :: Int + , filling :: String + } +makeFieldsId ''Taco +makeFieldsId ''Burrito + +checkTacoHardShell :: Lens' Taco Bool +checkTacoHardShell = hardShell + +checkBurritoFilling :: Lens' Burrito String +checkBurritoFilling = filling diff --git a/tests/T917.hs b/tests/T917.hs new file mode 100644 --- /dev/null +++ b/tests/T917.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module T917 where + +import Control.Lens +import Data.Kind +import Data.Proxy + +-- Like Data.Functor.Const, but redefined to ensure that it is poly-kinded +-- across all versions of GHC, not just 8.0+ +newtype Constant a (b :: k) = Constant a + +data T917OneA (a :: k -> Type) (b :: k -> Type) = MkT917OneA +data T917OneB a b = MkT917OneB (T917OneA a (Const b)) +$(makePrisms ''T917OneB) + +data T917TwoA (a :: k -> Type) (b :: k -> Type) = MkT917TwoA +data T917TwoB a b = MkT917TwoB (T917TwoA a (Const b)) +$(makeClassyPrisms ''T917TwoB) + +data family T917DataFam (a :: k) +data instance T917DataFam (a :: Type) = MkT917DataFam { _unT917DataFam :: Proxy a } +$(makeLenses 'MkT917DataFam) + +data T917GadtOne (a :: k) where + MkT917GadtOne :: T917GadtOne (a :: Type) +$(makePrisms ''T917GadtOne) + +data T917GadtTwo (a :: k) where + MkT917GadtTwo :: T917GadtTwo (a :: Type) +$(makePrisms ''T917GadtTwo) diff --git a/tests/T972.hs b/tests/T972.hs new file mode 100644 --- /dev/null +++ b/tests/T972.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module T972 where + +import Control.Lens +import Data.Proxy + +newtype Arc s = Arc { _unArc :: Int } + +data Direction = Negative | Positive +data Dart s = Dart { _arc :: Arc s, _direction :: Direction } +$(makeLenses ''Dart) + +data Fancy k (a :: k) = MkFancy { _unFancy1 :: k, _unFancy2 :: Proxy a } +$(makeLenses ''Fancy) diff --git a/tests/doctests.hs b/tests/doctests.hs --- 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 @@ -1,12 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# 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,14 +23,18 @@ import Control.Lens import Control.Monad.State import Data.Char -import Data.List as List -import Data.Map as Map +import qualified Data.Text as StrictT +import qualified Data.Text.Lazy as LazyT +import qualified Data.ByteString as StrictB +import qualified Data.ByteString.Lazy as LazyB +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif -import Test.Framework.Providers.HUnit -import Test.Framework -import Test.HUnit hiding (test) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) data Point = @@ -80,8 +79,8 @@ { _points = [ Point { _x = 0, _y = 0 } , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] - , _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin") - , (Point { _x = 4, _y = 7 }, "Peak") ] + , _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "Origin") + , (Point { _x = 4, _y = 7 }, "Peak") ] , _box = Box { _low = Point { _x = 0, _y = 0 } , _high = Point { _x = 8, _y = 7 } } } @@ -231,16 +230,96 @@ test = points <<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_prepend_to_record_field = + (trig & points <>:~ [ origin ]) + @?= trig { _points = [ origin ] <> (trig & _points) } + +case_prepend_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points <>:= [ origin ] + trig' = trig { _points = [ origin ] <> (trig & _points) } + +case_prepend_to_record_field_and_access_new_value = + (trig & points <<>:~ [ origin ]) + @?= ([ origin ] <> _points trig, trig { _points = [ origin ] <> (trig & _points) }) + +case_prepend_to_state_record_field_and_access_new_value = do + runState test trig @?= ([ origin ] <> _points trig, trig') + where + test = points <<>:= [ origin ] + trig' = trig { _points = [ origin ] <> (trig & _points) } + +case_cons_to_record_field = + (trig & points <|~ origin) + @?= trig { _points = origin : (trig & _points) } + +case_cons_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points <|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_cons_to_record_field_and_access_new_value = + (trig & points <<|~ origin) + @?= (origin : _points trig, trig { _points = origin : (trig & _points) }) + +case_cons_to_state_record_field_and_access_new_value = + runState test trig @?= ([ origin ] <> _points trig, trig') + where + test = points <<|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_snoc_to_record_field = + (trig & points |>~ origin) + @?= trig { _points = (trig & _points) `snoc` origin } + +case_snoc_to_state_record_field = do + runState test trig @?= ((), trig') + where + test = points |>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + +case_snoc_to_record_field_and_access_new_value = + (trig & points <|>~ origin) + @?= (_points trig `snoc` origin, trig { _points = (trig & _points) `snoc` origin }) + +case_snoc_to_state_record_field_and_access_new_value = + runState test trig @?= (_points trig <> [ origin ], trig') + where + test = points <|>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + case_append_to_record_field_and_access_old_value = - (trig & points <<%~ (<>[origin])) + (trig & points <<<>~ [ origin ]) @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] }) case_append_to_state_record_field_and_access_old_value = do runState test trig @?= (_points trig, trig') where - test = points <<%= (<>[origin]) + test = points <<<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_cons_to_record_field_and_access_old_value = + (trig & points <<<|~ origin) + @?= (_points trig, trig { _points = origin : (trig & _points) }) + +case_cons_to_state_record_field_and_access_old_value = + runState test trig @?= (_points trig, trig') + where + test = points <<<|= origin + trig' = trig { _points = origin : (trig & _points) } + +case_snoc_to_record_field_and_access_old_value = + (trig & points <<|>~ origin) + @?= (_points trig, trig { _points = (trig & _points) `snoc` origin }) + +case_snoc_to_state_record_field_and_access_old_value = + runState test trig @?= (_points trig, trig') + where + test = points <<|>= origin + trig' = trig { _points = (trig & _points) `snoc` origin } + case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin" case_read_maybe_state_map_entry = @@ -254,18 +333,18 @@ case_modify_map_entry = (trig & labels.ix origin %~ List.map toUpper) - @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN") - , (Point { _x = 4, _y = 7 }, "Peak") ] } + @?= trig { _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN") + , (Point { _x = 4, _y = 7 }, "Peak") ] } case_insert_maybe_map_entry = (trig & labels.at (Point { _x = 8, _y = 0 }) .~ Just "Right") - @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin") - , (Point { _x = 4, _y = 7 }, "Peak") - , (Point { _x = 8, _y = 0 }, "Right") ] } + @?= trig { _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "Origin") + , (Point { _x = 4, _y = 7 }, "Peak") + , (Point { _x = 8, _y = 0 }, "Right") ] } case_delete_maybe_map_entry = (trig & labels.at origin .~ Nothing) - @?= trig { _labels = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } + @?= trig { _labels = Map.fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } case_read_list_entry = (trig ^? points.element 0) @@ -283,43 +362,78 @@ , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] } +case_correct_indexing_strict_text = + map (\i -> StrictT.pack "12" ^? ix i) [-1..2] + @?= [Nothing, Just '1', Just '2', Nothing] + +case_correct_indexing_lazy_text = + map (\i -> LazyT.pack "12" ^? ix i) [-1..2] + @?= [Nothing, Just '1', Just '2', Nothing] + +case_correct_indexing_strict_bytestring = + map (\i -> StrictB.pack [1,2] ^? ix i) [-1..2] + @?= [Nothing, Just 1, Just 2, Nothing] + +case_correct_indexing_lazy_bytestring = + map (\i -> LazyB.pack [1,2] ^? ix i) [-1..2] + @?= [Nothing, Just 1, Just 2, Nothing] + main :: IO () -main = defaultMain - [ testGroup "Main" - [ testCase "read record field" case_read_record_field - , testCase "read state record field" case_read_state_record_field - , testCase "read record field and apply function" case_read_record_field_and_apply_function - , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function - , testCase "write record field" case_write_record_field - , testCase "write state record field" case_write_state_record_field - , testCase "write record field and access new value" case_write_record_field_and_access_new_value - , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value - , testCase "write record field and access old value" case_write_record_field_and_access_old_value - , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value - , testCase "modify record field" case_modify_record_field - , testCase "modify state record field" case_modify_state_record_field - , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value - , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value - , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value - , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value - , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result - , testCase "increment record field" case_increment_record_field - , testCase "increment state record field" case_increment_state_record_field - , testCase "append to record field" case_append_to_record_field - , testCase "append to state record field" case_append_to_state_record_field - , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value - , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value - , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value - , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value - , testCase "read maybe map entry" case_read_maybe_map_entry - , testCase "read maybe state map entry" case_read_maybe_state_map_entry - , testCase "read map entry" case_read_map_entry - , testCase "read state map entry" case_read_state_map_entry - , testCase "modify map entry" case_modify_map_entry - , testCase "insert maybe map entry" case_insert_maybe_map_entry - , testCase "delete maybe map entry" case_delete_maybe_map_entry - , testCase "read list entry" case_read_list_entry - , testCase "write list entry" case_write_list_entry - , testCase "write through list entry" case_write_through_list_entry - ] +main = defaultMain $ + testGroup "Main" + [ testCase "read record field" case_read_record_field + , testCase "read state record field" case_read_state_record_field + , testCase "read record field and apply function" case_read_record_field_and_apply_function + , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function + , testCase "write record field" case_write_record_field + , testCase "write state record field" case_write_state_record_field + , testCase "write record field and access new value" case_write_record_field_and_access_new_value + , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value + , testCase "write record field and access old value" case_write_record_field_and_access_old_value + , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value + , testCase "modify record field" case_modify_record_field + , testCase "modify state record field" case_modify_state_record_field + , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value + , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value + , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value + , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value + , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result + , testCase "increment record field" case_increment_record_field + , testCase "increment state record field" case_increment_state_record_field + , testCase "append to record field" case_append_to_record_field + , testCase "append to state record field" case_append_to_state_record_field + , testCase "prepend to record field" case_prepend_to_record_field + , testCase "prepend to state record field" case_prepend_to_state_record_field + , testCase "cons to record field" case_cons_to_record_field + , testCase "cons to state record field" case_cons_to_state_record_field + , testCase "snoc to record field" case_snoc_to_record_field + , testCase "snoc to state record field" case_snoc_to_state_record_field + , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value + , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value + , testCase "prepend to record field and access new value" case_prepend_to_record_field_and_access_new_value + , testCase "prepend to state record field and access new value" case_prepend_to_state_record_field_and_access_new_value + , testCase "cons to record field and access new value" case_cons_to_record_field_and_access_new_value + , testCase "cons to state record field and access new value" case_cons_to_state_record_field_and_access_new_value + , testCase "snoc to record field and access new value" case_snoc_to_record_field_and_access_new_value + , testCase "snoc to state record field and access new value" case_snoc_to_state_record_field_and_access_new_value + , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value + , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value + , testCase "cons to record field and access old value" case_cons_to_record_field_and_access_old_value + , testCase "cons to state record field and access old value" case_cons_to_state_record_field_and_access_old_value + , testCase "snoc to record field and access old value" case_snoc_to_record_field_and_access_old_value + , testCase "snoc to state record field and access old value" case_snoc_to_state_record_field_and_access_old_value + , testCase "read maybe map entry" case_read_maybe_map_entry + , testCase "read maybe state map entry" case_read_maybe_state_map_entry + , testCase "read map entry" case_read_map_entry + , testCase "read state map entry" case_read_state_map_entry + , testCase "modify map entry" case_modify_map_entry + , testCase "insert maybe map entry" case_insert_maybe_map_entry + , testCase "delete maybe map entry" case_delete_maybe_map_entry + , testCase "read list entry" case_read_list_entry + , testCase "write list entry" case_write_list_entry + , testCase "write through list entry" case_write_through_list_entry + , testCase "correct indexing strict text" case_correct_indexing_strict_text + , testCase "correct indexing lazy text" case_correct_indexing_lazy_text + , testCase "correct indexing strict bytestring" case_correct_indexing_strict_bytestring + , testCase "correct indexing lazy bytestring" case_correct_indexing_lazy_bytestring ] diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} @@ -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) @@ -26,19 +24,13 @@ ----------------------------------------------------------------------------- module Main where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif import Control.Lens import Test.QuickCheck -import Test.Framework -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) import Data.Char (isAlphaNum, isAscii, toUpper) -import Data.Text.Strict.Lens -import Data.List.Lens -#if __GLASGOW_HASKELL__ >= 708 +import qualified Data.Text.Strict.Lens as Text import GHC.Exts (Constraint) -#endif import Numeric (showHex, showOct, showSigned) import Numeric.Lens import Control.Lens.Properties (isIso, isLens, isPrism, isSetter, isTraversal) @@ -90,7 +82,7 @@ prop_prefixed s = isPrism (prefixed s :: Prism' String String) -- Data.Text.Lens -prop_text s = s^.packed.from packed == s +prop_text s = s^.Text.packed.from Text.packed == s --prop_text = isIso packed -- Numeric.Lens @@ -114,15 +106,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,44 +123,37 @@ 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 main :: IO () -main = defaultMain - [ testGroup "Main" - [ testProperty "1" prop_1 - , testProperty "2" prop_2 - , testProperty "3" prop_3 - , testProperty "4" prop_4 - , testProperty "5" prop_5 - , testProperty "6" prop_6 - , testProperty "7" prop_7 - , testProperty "8" prop_8 - , testProperty "9" prop_9 - , testProperty "10" prop_10 - , testProperty "2 2" prop_2_2 - , testProperty "mapped" prop_mapped - , testProperty "mapped mapped" prop_mapped_mapped - , testProperty "both" prop_both - , testProperty "traverseLeft" prop_traverseLeft - , testProperty "traverseRight" prop_traverseRight - , testProperty "simple" prop_simple - , testProperty " Left" prop__Left - , testProperty " Right" prop__Right - , testProperty " Just" prop__Just - , testProperty "prefixed" prop_prefixed - , testProperty "text" prop_text - , testProperty "base show" prop_base_show - , testProperty "base read" prop_base_read - , testProperty "base readFail" prop_base_readFail - ] +main = defaultMain $ + testGroup "Main" + [ testProperty "1" prop_1 + , testProperty "2" prop_2 + , testProperty "3" prop_3 + , testProperty "4" prop_4 + , testProperty "5" prop_5 + , testProperty "6" prop_6 + , testProperty "7" prop_7 + , testProperty "8" prop_8 + , testProperty "9" prop_9 + , testProperty "10" prop_10 + , testProperty "2 2" prop_2_2 + , testProperty "mapped" prop_mapped + , testProperty "mapped mapped" prop_mapped_mapped + , testProperty "both" prop_both + , testProperty "traverseLeft" prop_traverseLeft + , testProperty "traverseRight" prop_traverseRight + , testProperty "simple" prop_simple + , testProperty " Left" prop__Left + , testProperty " Right" prop__Right + , testProperty " Just" prop__Just + , testProperty "prefixed" prop_prefixed + , testProperty "text" prop_text + , testProperty "base show" prop_base_show + , testProperty "base read" prop_base_read + , testProperty "base readFail" prop_base_readFail ] diff --git a/tests/templates.hs b/tests/templates.hs --- a/tests/templates.hs +++ b/tests/templates.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,7 +27,10 @@ import Control.Lens -- import Test.QuickCheck (quickCheck) +import BigRecord () import T799 () +import T917 () +import T972 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar @@ -312,7 +316,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 +326,6 @@ checkFm1 :: Lens' (Family Int (a, b) a) Int checkFm1 = fm1 -#endif - class Class a where data Associated a method :: a -> Int @@ -342,7 +343,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 +367,6 @@ checkC0' :: Traversal' (DeclaredFields f a) String checkC0' = c0 -#endif declareFields [d| data Aardvark = Aardvark { aardvarkAlbatross :: Int } @@ -451,6 +450,31 @@ $(makeClassyPrisms ''T865) instance AsT866 T865 where _T866 = __T865 . _T866 + +-- {make,declare}Wrapped test cases for ordinary data types +newtype T997A a = MkT997A a +$(makeWrapped ''T997A) + +$(declareWrapped [d| + newtype T997B b = MkT997B b + |]) + +-- {make,declare}Wrapped test cases for data family instances (#997) +data family T997FamA a +newtype instance T997FamA a = MkT997FamA a +$(makeWrapped 'MkT997FamA) + +$(declareWrapped [d| + data family T997FamB b + newtype instance T997FamB b = MkT997FamB b + |]) + +-- Ensure that a data type defined in a TH quote can have a field whose type +-- references another data type defined in the same quote (#1032) +declareFields [d| + data T1032A = T1032A { t1032ASubB :: T1032B } + data T1032B = T1032B { t1032BB :: Int } + |] main :: IO () main = putStrLn "test/templates.hs: ok" diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install deleted file mode 100644 --- a/travis/cabal-apt-install +++ /dev/null @@ -1,22 +0,0 @@ -#! /bin/bash -set -eu - -APT="sudo apt-get -q -y" -CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" - -$APT update -$APT install dctrl-tools - -# Find potential system packages to satisfy cabal dependencies -deps() -{ - local M='^\([^ ]\+\)-[0-9.]\+ (.*$' - local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' - local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ - | sed -ne "s/$M/$G/p" | sort -u)" - grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u -} - -$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special -$CABAL_INSTALL_DEPS --constraint='hlint installed' "$@" # Install the rest via Hackage - diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -1,16 +0,0 @@ --- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix --- --- This is particularly useful for travis-ci to get it to stop complaining --- about a broken build when everything is still correct on our end. --- --- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead --- --- To enable this, uncomment the before_script in .travis.yml - -remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive -remote-repo-cache: ~/.cabal/packages -world-file: ~/.cabal/world -build-summary: ~/.cabal/logs/build.log -remote-build-reporting: anonymous -install-dirs user -install-dirs global