diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,25 @@ +- arguments: [--cpp-define=HLINT, --cpp-ansi, --cpp-include=include] + +- ignore: {name: Reduce duplication} +- ignore: {name: Redundant lambda} +- ignore: {name: Use >=>} +- ignore: {name: Use const} +- ignore: {name: Use module export list} +- ignore: {name: Use lambda-case} +- ignore: {name: Use tuple-section} +- ignore: {name: Use fewer imports} +- ignore: {name: "Use :"} +- ignore: {name: Use typeRep, within: [Control.Lens.Internal.Typeable, Control.Lens.Internal.Exception]} +- ignore: {name: Eta reduce, within: [Control.Lens.Zoom]} # Breaks code +- ignore: {name: Use camelCase, within: [Control.Lens.Internal.TH]} +- ignore: {name: Use list comprehension, within: [Control.Lens.Internal.FieldTH]} + +- fixity: "infixl 9 :>" +- fixity: "infixr 9 <.>, <., .>, ..." +- fixity: "infixr 9 #." +- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#" +- fixity: "infixr 8 ^!, ^@!" +- fixity: "infixr 4 ~, <~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, , ??" diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -4,27 +4,24 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.2.1 +# version: 0.3.20190814.1 # language: c dist: xenial - git: - submodules: false # whether to recursively clone submodules - + # whether to recursively clone submodules + submodules: false notifications: irc: channels: - - "irc.freenode.org#haskell-lens" + - irc.freenode.org#haskell-lens skip_join: true template: - - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - + - "\"\\x0313lens\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\"" cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store - before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' @@ -33,131 +30,158 @@ - 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 - matrix: include: - - compiler: "ghc-8.6.4" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-8.4.4" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-7.10.3" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-7.8.4" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-7.6.3" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-7.4.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.4.2,freeglut3-dev], sources: [hvr-ghc]}} - - compiler: "ghc-head" - env: GHCHEAD=true - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head,freeglut3-dev], sources: [hvr-ghc]}} - + - compiler: ghc-8.8.1 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0","freeglut3-dev"]}} + - compiler: ghc-8.6.5 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-8.4.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-8.2.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-8.0.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-7.10.3 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-7.8.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-7.6.3 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-7.4.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-2.4","freeglut3-dev"]}} + - compiler: ghc-head + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head","freeglut3-dev"]}} allow_failures: - - compiler: "ghc-head" - + - compiler: ghc-head + - compiler: ghc-8.8.1 before_install: - - HC=/opt/ghc/bin/${CC} - - HCPKG=${HC/ghc/ghc-pkg} + - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') + - WITHCOMPILER="-w $HC" + - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH" - - ROOTDIR=$(pwd) - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - 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+markoutput" + - set -o pipefail + - | + echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk + echo 'BEGIN { state = "output"; }' >> .colorful.awk + echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk + echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk + echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk + echo ' if (state == "cabal") {' >> .colorful.awk + echo ' print blue($0)' >> .colorful.awk + echo ' } else {' >> .colorful.awk + echo ' print $0' >> .colorful.awk + echo ' }' >> .colorful.awk + echo '}' >> .colorful.awk + - cat .colorful.awk + - | + color_cabal_output () { + awk -f $TOP/.colorful.awk + } + - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - - GHCHEAD=${GHCHEAD-false} - - travis_retry ${CABAL} update -v - - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config - - rm -fv cabal.project cabal.project.local - # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage + - HEADHACKAGE=false + - if [ $HCNUMVER -ge 80800 ] ; then HEADHACKAGE=true ; fi + - rm -f $CABALHOME/config - | - if $GHCHEAD; then - sed -i 's/-- allow-newer: .*/allow-newer: *:base/' $CABALHOME/config - for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" $CABALHOME/config; done - - echo 'repository head.hackage' >> $CABALHOME/config - echo ' url: http://head.hackage.haskell.org/' >> $CABALHOME/config - echo ' secure: True' >> $CABALHOME/config - echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> $CABALHOME/config - echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> $CABALHOME/config - echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> $CABALHOME/config - echo ' key-threshold: 3' >> $CABALHOME.config - - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' - - ${CABAL} new-update head.hackage -v + 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 + - | + if $HEADHACKAGE; then + echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config + echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config + echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config + echo " secure: True" >> $CABALHOME/config + echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config + echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config + echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config + echo " key-threshold: 3" >> $CABALHOME/config fi - - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' - - if [ $HCNUMVER -eq 80604 ] ; then ${CABAL} new-install -w ${HC} -j2 hlint --constraint='hlint ==2.1.*' ; fi - - rm -f cabal.project + - cat $CABALHOME/config + - rm -fv cabal.project cabal.project.local cabal.project.freeze + - travis_retry ${CABAL} v2-update -v + - if [ $HCNUMVER -ge 80600 ] && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-install $WITHCOMPILER -j2 hlint --constraint='hlint ==2.1.*' | color_cabal_output ; fi + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - - "printf 'packages: \".\"\\n' >> cabal.project" - - "printf 'packages: \"./examples\"\\n' >> cabal.project" - - "printf 'packages: \"./lens-properties\"\\n' >> cabal.project" - - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - - touch cabal.project.local - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(lens|lens-examples|lens-properties)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - | + echo "packages: ." >> cabal.project + echo "packages: ./examples" >> cabal.project + echo "packages: ./lens-properties" >> cabal.project + - | + - "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 - - rm -f cabal.project.freeze - - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry - - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm "cabal.project.freeze" - - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - rm -rf .ghc.environment.* "."/dist "./examples"/dist "./lens-properties"/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm cabal.project.freeze + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output script: - # test that source-distributions can be generated - - ${CABAL} new-sdist all + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + # Packaging... + - ${CABAL} v2-sdist all | color_cabal_output + # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - rm -f cabal.project + - 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 - - "printf 'packages: \"lens-*/*.cabal\"\\n' >> cabal.project" - - "printf 'packages: \"lens-examples-*/*.cabal\"\\n' >> cabal.project" - - "printf 'packages: \"lens-properties-*/*.cabal\"\\n' >> cabal.project" - - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - - touch cabal.project.local - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(lens|lens-examples|lens-properties)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - | + echo "packages: ${PKGDIR_lens}" >> cabal.project + echo "packages: ${PKGDIR_lens_examples}" >> cabal.project + echo "packages: ${PKGDIR_lens_properties}" >> cabal.project + - | + - "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} new-build -w ${HC} ${TEST} ${BENCH} all - - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all; fi - - # hlint - - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-* && hlint --cpp-ansi --cpp-define=HLINT src) ; fi - - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-examples-* && hlint --cpp-ansi --cpp-define=HLINT .) ; fi - - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-examples-* && hlint --cpp-ansi --cpp-define=HLINT .) ; fi - - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-properties-* && hlint --cpp-ansi --cpp-define=HLINT src) ; fi - - # cabal check - - (cd lens-* && ${CABAL} check) - - (cd lens-examples-* && ${CABAL} check) - - (cd lens-properties-* && ${CABAL} check) - - # haddock - - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # Testing... + - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # HLint.. + - if [ $HCNUMVER -ge 80600 ] && [ $HCNUMVER -lt 80800 ] ; then (cd ${PKGDIR_lens} && hlint src) ; fi + - if [ $HCNUMVER -ge 80600 ] && [ $HCNUMVER -lt 80800 ] ; then (cd ${PKGDIR_lens_examples} && hlint .) ; fi + - if [ $HCNUMVER -ge 80600 ] && [ $HCNUMVER -lt 80800 ] ; 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... + - ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # REGENDATA ["--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,12 +1,51 @@ +4.18 [2019.09.06] +----------------- +* Support building with GHC 8.8. +* Add `xplat` and `xplatf`. +* Flip `auf` to take the `Iso` in the same direction as `au`. + Use the new `xplatf` or just call `coerce` for the old form. +* Weaken `holeInOne`'s `Category p` constraint to `Comonad (Corep p)`. +* Generalize the type of `GHC.Generics.Lens.generic1` from + `Iso' (f a) (Rep1 f a)` to `Iso (f a) (f b) (Rep1 f a) (Rep1 f b)`. +* `makeClassyPrisms` now supports generating prisms for data types that share + a name with one of its constructors. In such a scenario, the name of the + classy prism for the data type will be prefixed with an extra `_` (for + prefix names) or `.` (for infix names) to disambiguate it from the prism + for the constructor. +* Several type classes in `Control.Exception.Lens` now have additional + prisms corresponding to the data type that they focus on, in accordance + with the new convention established in the bullet point above. For example, + `AsNonTermination` now has an additional + `__NonTermination :: Prism' t NonTermination` method, and the existing + `_NonTermination :: Prism' t ()` method now has a default implementation in + terms of `__NonTermination`. + + As a consequence of this change, you may need to update instances of these + classes to implement the new prisms. +* Add additional bifunctor instances for `Swapped`. +* New lenses `head1` and `last1`, to access the first/last elements of + a `Traversable1` container. +* Add `filteredBy`. +* Add `adjoin` to `Control.Lens.Unsound`. +* Add `Each (Either a a) (Either b b) a b` instance. +* Make `magnify` offer its getter argument the `Contravariant` and `Functor` + instances it will require. This allows `magnify` to be used without + knowing the concrete monad being magnified. +* Add `equality`, `equality'`, `withEquality`, `underEquality`, `overEquality`, + `fromLeibniz`, `fromLeibniz'` and `cloneEquality` to `Control.Lens.Equality`. +* Add `withLens` to `Control.Lens.Lens`. +* Make `substEq` and `simply` in `Control.Lens.Equality` + and `withIso` in `Control.Lens.Iso` levity polymorphic. + 4.17.1 [2019.04.26] ------------------- * Support `th-abstraction-0.3.0.0` or later. * Only incur `semigroups` and `void` dependencies on old GHCs. -* Add `holes1Of`. -* Add `locally` (https://github.com/ekmett/lens/pull/829). -* Add `ilocally` (https://github.com/ekmett/lens/pull/836). -* Add a third `Prism` law. -* Add `gplate1`. +* Add `holes1Of` +* Add `locally` https://github.com/ekmett/lens/pull/829 +* Add `ilocally` https://github.com/ekmett/lens/pull/836 +* Add third `Prism` law. +* Add `gplate1` * Add `Wrapped`/`Rewrapped` instances for `Data.Monoid.Ap`. 4.17 [2018.07.03] diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 --- a/HLint.hs +++ /dev/null @@ -1,40 +0,0 @@ -import "hint" HLint.HLint - -ignore "Reduce duplication" -ignore "Redundant lambda" -ignore "Use >=>" -ignore "Use const" -ignore "Use module export list" -ignore "Use lambda-case" -ignore "Use tuple-section" - --- Used hlint --find src/ in the lens repo to generate this: -infixl 9 :> - -infixr 9 <.>, <., .>, ... -infixr 9 #. - -infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! -infixl 8 ^., ^@. -infixl 8 ^# -infixl 8 .# - -infixr 8 ^!, ^@! - -infixr 4 ~, <~, <.>~, <<.>~ -infixr 4 <#~, #~, #%~, <#%~, #%%~ -infixr 4 .|.~, .&.~, <.|.~, <.&.~ -infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~ -infixr 4 %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>= -infix 4 <#=, #=, #%=, <#%=, #%%= -infix 4 .|.=, .&.=, <.|.=, <.&.= -infix 4 %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %= -infix 4 %%@=, <%@=, %%=, <+=, <*=, <-=, , ?? diff --git a/examples/.hlint.yaml b/examples/.hlint.yaml new file mode 100644 --- /dev/null +++ b/examples/.hlint.yaml @@ -0,0 +1,11 @@ +- arguments: [--cpp-define=HLINT, --cpp-ansi] + +- fixity: "infixl 9 :>" +- fixity: "infixr 9 <.>, <., .>, ..." +- fixity: "infixr 9 #." +- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#" +- fixity: "infixr 8 ^!, ^@!" +- fixity: "infixr 4 ~, <~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, , ??" diff --git a/examples/lens-examples.cabal b/examples/lens-examples.cabal --- a/examples/lens-examples.cabal +++ b/examples/lens-examples.cabal @@ -23,7 +23,8 @@ , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 source-repository head type: git diff --git a/images/Hierarchy.png b/images/Hierarchy.png Binary files a/images/Hierarchy.png and b/images/Hierarchy.png differ diff --git a/images/overview.png b/images/overview.png Binary files a/images/overview.png and b/images/overview.png differ diff --git a/lens-properties/.hlint.yaml b/lens-properties/.hlint.yaml new file mode 100644 --- /dev/null +++ b/lens-properties/.hlint.yaml @@ -0,0 +1,11 @@ +- arguments: [--cpp-define=HLINT, --cpp-ansi] +- ignore: { name: Use camelCase } +- fixity: "infixl 9 :>" +- fixity: "infixr 9 <.>, <., .>, ..." +- fixity: "infixr 9 #." +- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#" +- fixity: "infixr 8 ^!, ^@!" +- fixity: "infixr 4 ~, <~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, =, <=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, , ??" 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 @@ -20,7 +20,8 @@ , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 extra-source-files: .hlint.yaml 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.17.1 +version: 4.18 license: BSD2 cabal-version: 1.18 license-file: LICENSE @@ -19,7 +19,8 @@ , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types @@ -50,7 +51,7 @@ . <> . - + . 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,20 +98,22 @@ extra-source-files: .travis.yml .gitignore + .hlint.yaml .vim.custom cabal.project examples/LICENSE examples/lens-examples.cabal examples/*.hs examples/*.lhs + examples/.hlint.yaml include/*.h + lens-properties/.hlint.yaml lens-properties/CHANGELOG.markdown lens-properties/LICENSE lens-properties/Setup.hs lens-properties/lens-properties.cabal travis/cabal-apt-install travis/config - HLint.hs Warning.hs AUTHORS.markdown CHANGELOG.markdown @@ -125,7 +128,7 @@ custom-setup setup-depends: - Cabal >= 1.10 && <2.5, + Cabal >= 1.10 && <3.1, base >= 4.5 && <5, cabal-doctest >= 1 && <1.1, filepath @@ -198,8 +201,8 @@ base >= 4.5 && < 5, base-orphans >= 0.5.2 && < 1, bifunctors >= 5.1 && < 6, - bytestring >= 0.9.1.10 && < 0.11, - call-stack >= 0.1 && < 0.2, + 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, @@ -207,7 +210,7 @@ filepath >= 1.2.0.0 && < 1.5, free >= 4 && < 6, ghc-prim, - hashable >= 1.1.2.3 && < 1.3, + hashable >= 1.1.2.3 && < 1.4, kan-extensions >= 5 && < 6, exceptions >= 0.1.1 && < 1, mtl >= 2.0.1 && < 2.3, @@ -216,11 +219,12 @@ reflection >= 2.1 && < 3, semigroupoids >= 5 && < 6, tagged >= 0.4.4 && < 1, - template-haskell >= 2.4 && < 2.15, - th-abstraction >= 0.2.1 && < 0.4, + template-haskell >= 2.4 && < 2.16, + th-abstraction >= 0.3 && < 0.4, text >= 0.11 && < 1.3, transformers >= 0.2 && < 0.6, transformers-compat >= 0.4 && < 1, + type-equality >= 1 && < 2, unordered-containers >= 0.2.4 && < 0.3, vector >= 0.9 && < 0.13 @@ -269,6 +273,7 @@ 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 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 @@ -97,6 +97,7 @@ -- ** Assertion Failed , AsAssertionFailed(..) #if __GLASGOW_HASKELL__ >= 710 + , pattern AssertionFailed__ , pattern AssertionFailed_ #endif -- ** Async Exceptions @@ -115,37 +116,44 @@ -- ** 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 @@ -153,33 +161,41 @@ , 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(..) + , pattern CompactionFailed__ , pattern CompactionFailed_ #endif -- * Handling Exceptions , AsHandlingException(..) #if __GLASGOW_HASKELL__ >= 710 + , pattern HandlingException__ , pattern HandlingException_ #endif ) where @@ -496,8 +512,11 @@ -- | Arithmetic exceptions. class AsArithException t where + -- | + -- @ -- '_ArithException' :: 'Prism'' 'ArithException' 'ArithException' -- '_ArithException' :: 'Prism'' 'SomeException' 'ArithException' + -- @ _ArithException :: Prism' t ArithException #if __GLASGOW_HASKELL__ >= 710 @@ -719,6 +738,13 @@ -- | 'assert' was applied to 'Prelude.False'. class AsAssertionFailed t where + -- | + -- @ + -- '__AssertionFailed' :: 'Prism'' 'AssertionFailed' 'AssertionFailed' + -- '__AssertionFailed' :: 'Prism'' 'SomeException' 'AssertionFailed' + -- @ + __AssertionFailed :: Prism' t AssertionFailed + -- | This 'Exception' contains provides information about what assertion failed in the 'String'. -- -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("" `isInfixOf` xs) ) $ assert False (return "uncaught") @@ -729,16 +755,24 @@ -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String' -- @ _AssertionFailed :: Prism' t String + _AssertionFailed = __AssertionFailed._AssertionFailed + {-# INLINE _AssertionFailed #-} instance AsAssertionFailed AssertionFailed where + __AssertionFailed = id + {-# INLINE __AssertionFailed #-} + _AssertionFailed = _Wrapping AssertionFailed {-# INLINE _AssertionFailed #-} instance AsAssertionFailed SomeException where - _AssertionFailed = exception._Wrapping AssertionFailed - {-# INLINE _AssertionFailed #-} + __AssertionFailed = exception + {-# INLINE __AssertionFailed #-} #if __GLASGOW_HASKELL__ >= 710 +pattern AssertionFailed__ e <- (preview __AssertionFailed -> Just e) where + AssertionFailed__ e = review __AssertionFailed e + pattern AssertionFailed_ e <- (preview _AssertionFailed -> Just e) where AssertionFailed_ e = review _AssertionFailed e #endif @@ -859,6 +893,13 @@ -- not to terminate. Note that there is no guarantee that the runtime system -- will notice whether any given computation is guaranteed to terminate or not. class AsNonTermination t where + -- | + -- @ + -- '__NonTermination' :: 'Prism'' 'NonTermination' 'NonTermination' + -- '__NonTermination' :: 'Prism'' 'SomeException' 'NonTermination' + -- @ + __NonTermination :: Prism' t NonTermination + -- | There is no additional information carried in a 'NonTermination' 'Exception'. -- -- @ @@ -866,16 +907,24 @@ -- '_NonTermination' :: 'Prism'' 'SomeException' () -- @ _NonTermination :: Prism' t () + _NonTermination = __NonTermination._NonTermination + {-# INLINE _NonTermination #-} instance AsNonTermination NonTermination where + __NonTermination = id + {-# INLINE __NonTermination #-} + _NonTermination = trivial NonTermination {-# INLINE _NonTermination #-} instance AsNonTermination SomeException where - _NonTermination = exception.trivial NonTermination - {-# INLINE _NonTermination #-} + __NonTermination = exception + {-# INLINE __NonTermination #-} #if __GLASGOW_HASKELL__ >= 710 +pattern NonTermination__ e <- (preview __NonTermination -> Just e) where + NonTermination__ e = review __NonTermination e + pattern NonTermination_ <- (has _NonTermination -> True) where NonTermination_ = review _NonTermination () #endif @@ -887,6 +936,13 @@ -- | Thrown when the program attempts to call atomically, from the -- 'Control.Monad.STM' package, inside another call to atomically. class AsNestedAtomically t where + -- | + -- @ + -- '__NestedAtomically' :: 'Prism'' 'NestedAtomically' 'NestedAtomically' + -- '__NestedAtomically' :: 'Prism'' 'SomeException' 'NestedAtomically' + -- @ + __NestedAtomically :: Prism' t NestedAtomically + -- | There is no additional information carried in a 'NestedAtomically' 'Exception'. -- -- @ @@ -894,16 +950,24 @@ -- '_NestedAtomically' :: 'Prism'' 'SomeException' () -- @ _NestedAtomically :: Prism' t () + _NestedAtomically = __NestedAtomically._NestedAtomically + {-# INLINE _NestedAtomically #-} instance AsNestedAtomically NestedAtomically where + __NestedAtomically = id + {-# INLINE __NestedAtomically #-} + _NestedAtomically = trivial NestedAtomically {-# INLINE _NestedAtomically #-} instance AsNestedAtomically SomeException where - _NestedAtomically = exception.trivial NestedAtomically - {-# INLINE _NestedAtomically #-} + __NestedAtomically = exception + {-# INLINE __NestedAtomically #-} #if __GLASGOW_HASKELL__ >= 710 +pattern NestedAtomically__ e <- (preview __NestedAtomically -> Just e) where + NestedAtomically__ e = review __NestedAtomically e + pattern NestedAtomically_ <- (has _NestedAtomically -> True) where NestedAtomically_ = review _NestedAtomically () #endif @@ -916,6 +980,13 @@ -- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't -- ever continue. class AsBlockedIndefinitelyOnMVar t where + -- | + -- @ + -- '__BlockedIndefinitelyOnMVar' :: 'Prism'' 'BlockedIndefinitelyOnMVar' 'BlockedIndefinitelyOnMVar' + -- '__BlockedIndefinitelyOnMVar' :: 'Prism'' 'SomeException' 'BlockedIndefinitelyOnMVar' + -- @ + __BlockedIndefinitelyOnMVar :: Prism' t BlockedIndefinitelyOnMVar + -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'. -- -- @ @@ -923,16 +994,24 @@ -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'SomeException' () -- @ _BlockedIndefinitelyOnMVar :: Prism' t () + _BlockedIndefinitelyOnMVar = __BlockedIndefinitelyOnMVar._BlockedIndefinitelyOnMVar + {-# INLINE _BlockedIndefinitelyOnMVar #-} instance AsBlockedIndefinitelyOnMVar BlockedIndefinitelyOnMVar where + __BlockedIndefinitelyOnMVar = id + {-# INLINE __BlockedIndefinitelyOnMVar #-} + _BlockedIndefinitelyOnMVar = trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} instance AsBlockedIndefinitelyOnMVar SomeException where - _BlockedIndefinitelyOnMVar = exception.trivial BlockedIndefinitelyOnMVar - {-# INLINE _BlockedIndefinitelyOnMVar #-} + __BlockedIndefinitelyOnMVar = exception + {-# INLINE __BlockedIndefinitelyOnMVar #-} #if __GLASGOW_HASKELL__ >= 710 +pattern BlockedIndefinitelyOnMVar__ e <- (preview __BlockedIndefinitelyOnMVar -> Just e) where + BlockedIndefinitelyOnMVar__ e = review __BlockedIndefinitelyOnMVar e + pattern BlockedIndefinitelyOnMVar_ <- (has _BlockedIndefinitelyOnMVar -> True) where BlockedIndefinitelyOnMVar_ = review _BlockedIndefinitelyOnMVar () #endif @@ -945,6 +1024,13 @@ -- but there are no other references to any TVars involved, so it can't ever -- continue. class AsBlockedIndefinitelyOnSTM t where + -- | + -- @ + -- '__BlockedIndefinitelyOnSTM' :: 'Prism'' 'BlockedIndefinitelyOnSTM' 'BlockedIndefinitelyOnSTM' + -- '__BlockedIndefinitelyOnSTM' :: 'Prism'' 'SomeException' 'BlockedIndefinitelyOnSTM' + -- @ + __BlockedIndefinitelyOnSTM :: Prism' t BlockedIndefinitelyOnSTM + -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'. -- -- @ @@ -952,16 +1038,24 @@ -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'SomeException' () -- @ _BlockedIndefinitelyOnSTM :: Prism' t () + _BlockedIndefinitelyOnSTM = __BlockedIndefinitelyOnSTM._BlockedIndefinitelyOnSTM + {-# INLINE _BlockedIndefinitelyOnSTM #-} instance AsBlockedIndefinitelyOnSTM BlockedIndefinitelyOnSTM where + __BlockedIndefinitelyOnSTM = id + {-# INLINE __BlockedIndefinitelyOnSTM #-} + _BlockedIndefinitelyOnSTM = trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} instance AsBlockedIndefinitelyOnSTM SomeException where - _BlockedIndefinitelyOnSTM = exception.trivial BlockedIndefinitelyOnSTM - {-# INLINE _BlockedIndefinitelyOnSTM #-} + __BlockedIndefinitelyOnSTM = exception + {-# INLINE __BlockedIndefinitelyOnSTM #-} #if __GLASGOW_HASKELL__ >= 710 +pattern BlockedIndefinitelyOnSTM__ e <- (preview __BlockedIndefinitelyOnSTM -> Just e) where + BlockedIndefinitelyOnSTM__ e = review __BlockedIndefinitelyOnSTM e + pattern BlockedIndefinitelyOnSTM_ <- (has _BlockedIndefinitelyOnSTM -> True) where BlockedIndefinitelyOnSTM_ = review _BlockedIndefinitelyOnSTM () #endif @@ -973,6 +1067,13 @@ -- | There are no runnable threads, so the program is deadlocked. The -- 'Deadlock' 'Exception' is raised in the main thread only. class AsDeadlock t where + -- | + -- @ + -- '__Deadlock' :: 'Prism'' 'Deadlock' 'Deadlock' + -- '__Deadlock' :: 'Prism'' 'SomeException' 'Deadlock' + -- @ + __Deadlock :: Prism' t Deadlock + -- | There is no information carried in a 'Deadlock' 'Exception'. -- -- @ @@ -980,16 +1081,24 @@ -- '_Deadlock' :: 'Prism'' 'SomeException' () -- @ _Deadlock :: Prism' t () + _Deadlock = __Deadlock._Deadlock + {-# INLINE _Deadlock #-} instance AsDeadlock Deadlock where + __Deadlock = id + {-# INLINE __Deadlock #-} + _Deadlock = trivial Deadlock {-# INLINE _Deadlock #-} instance AsDeadlock SomeException where - _Deadlock = exception.trivial Deadlock - {-# INLINE _Deadlock #-} + __Deadlock = exception + {-# INLINE __Deadlock #-} #if __GLASGOW_HASKELL__ >= 710 +pattern Deadlock__ e <- (preview __Deadlock -> Just e) where + Deadlock__ e = review __Deadlock e + pattern Deadlock_ <- (has _Deadlock -> True) where Deadlock_ = review _Deadlock () #endif @@ -1001,6 +1110,13 @@ -- | A class method without a definition (neither a default definition, -- nor a definition in the appropriate instance) was called. class AsNoMethodError t where + -- | + -- @ + -- '__NoMethodError' :: 'Prism'' 'NoMethodError' 'NoMethodError' + -- '__NoMethodError' :: 'Prism'' 'SomeException' 'NoMethodError' + -- @ + __NoMethodError :: Prism' t NoMethodError + -- | Extract a description of the missing method. -- -- @ @@ -1008,16 +1124,24 @@ -- '_NoMethodError' :: 'Prism'' 'SomeException' 'String' -- @ _NoMethodError :: Prism' t String + _NoMethodError = __NoMethodError._NoMethodError + {-# INLINE _NoMethodError #-} instance AsNoMethodError NoMethodError where + __NoMethodError = id + {-# INLINE __NoMethodError #-} + _NoMethodError = _Wrapping NoMethodError {-# INLINE _NoMethodError #-} instance AsNoMethodError SomeException where - _NoMethodError = exception._Wrapping NoMethodError - {-# INLINE _NoMethodError #-} + __NoMethodError = exception + {-# INLINE __NoMethodError #-} #if __GLASGOW_HASKELL__ >= 710 +pattern NoMethodError__ e <- (preview __NoMethodError -> Just e) where + NoMethodError__ e = review __NoMethodError e + pattern NoMethodError_ e <- (preview _NoMethodError -> Just e) where NoMethodError_ e = review _NoMethodError e #endif @@ -1028,6 +1152,13 @@ -- | A pattern match failed. class AsPatternMatchFail t where + -- | + -- @ + -- '__PatternMatchFail' :: 'Prism'' 'PatternMatchFail' 'PatternMatchFail' + -- '__PatternMatchFail' :: 'Prism'' 'SomeException' 'PatternMatchFail' + -- @ + __PatternMatchFail :: Prism' t PatternMatchFail + -- | Information about the source location of the pattern. -- -- @ @@ -1035,16 +1166,24 @@ -- '_PatternMatchFail' :: 'Prism'' 'SomeException' 'String' -- @ _PatternMatchFail :: Prism' t String + _PatternMatchFail = __PatternMatchFail._PatternMatchFail + {-# INLINE _PatternMatchFail #-} instance AsPatternMatchFail PatternMatchFail where + __PatternMatchFail = id + {-# INLINE __PatternMatchFail #-} + _PatternMatchFail = _Wrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} instance AsPatternMatchFail SomeException where - _PatternMatchFail = exception._Wrapping PatternMatchFail - {-# INLINE _PatternMatchFail #-} + __PatternMatchFail = exception + {-# INLINE __PatternMatchFail #-} #if __GLASGOW_HASKELL__ >= 710 +pattern PatternMatchFail__ e <- (preview __PatternMatchFail -> Just e) where + PatternMatchFail__ e = review __PatternMatchFail e + pattern PatternMatchFail_ e <- (preview _PatternMatchFail -> Just e) where PatternMatchFail_ e = review _PatternMatchFail e #endif @@ -1055,6 +1194,13 @@ -- | An uninitialised record field was used. class AsRecConError t where + -- | + -- @ + -- '__RecConError' :: 'Prism'' 'RecConError' 'RecConError' + -- '__RecConError' :: 'Prism'' 'SomeException' 'RecConError' + -- @ + __RecConError :: Prism' t RecConError + -- | Information about the source location where the record was -- constructed. -- @@ -1063,16 +1209,24 @@ -- '_RecConError' :: 'Prism'' 'SomeException' 'String' -- @ _RecConError :: Prism' t String + _RecConError = __RecConError._RecConError + {-# INLINE _RecConError #-} instance AsRecConError RecConError where + __RecConError = id + {-# INLINE __RecConError #-} + _RecConError = _Wrapping RecConError {-# INLINE _RecConError #-} instance AsRecConError SomeException where - _RecConError = exception._Wrapping RecConError - {-# INLINE _RecConError #-} + __RecConError = exception + {-# INLINE __RecConError #-} #if __GLASGOW_HASKELL__ >= 710 +pattern RecConError__ e <- (preview __RecConError -> Just e) where + RecConError__ e = review __RecConError e + pattern RecConError_ e <- (preview _RecConError -> Just e) where RecConError_ e = review _RecConError e #endif @@ -1085,18 +1239,38 @@ -- field. This can only happen with a datatype with multiple constructors, -- where some fields are in one constructor but not another. class AsRecSelError t where + -- | + -- @ + -- '__RecSelError' :: 'Prism'' 'RecSelError' 'RecSelError' + -- '__RecSelError' :: 'Prism'' 'SomeException' 'RecSelError' + -- @ + __RecSelError :: Prism' t RecSelError + -- | Information about the source location where the record selection occurred. + -- + -- @ + -- '_RecSelError' :: 'Prism'' 'RecSelError' 'String' + -- '_RecSelError' :: 'Prism'' 'SomeException' 'String' + -- @ _RecSelError :: Prism' t String + _RecSelError = __RecSelError._RecSelError + {-# INLINE _RecSelError #-} instance AsRecSelError RecSelError where + __RecSelError = id + {-# INLINE __RecSelError #-} + _RecSelError = _Wrapping RecSelError {-# INLINE _RecSelError #-} instance AsRecSelError SomeException where - _RecSelError = exception._Wrapping RecSelError - {-# INLINE _RecSelError #-} + __RecSelError = exception + {-# INLINE __RecSelError #-} #if __GLASGOW_HASKELL__ >= 710 +pattern RecSelError__ e <- (preview __RecSelError -> Just e) where + RecSelError__ e = review __RecSelError e + pattern RecSelError_ e <- (preview _RecSelError -> Just e) where RecSelError_ e = review _RecSelError e #endif @@ -1109,18 +1283,38 @@ -- appropriate field. This can only happen with a datatype with multiple -- constructors, where some fields are in one constructor but not another. class AsRecUpdError t where + -- | + -- @ + -- '__RecUpdError' :: 'Prism'' 'RecUpdError' 'RecUpdError' + -- '__RecUpdError' :: 'Prism'' 'SomeException' 'RecUpdError' + -- @ + __RecUpdError :: Prism' t RecUpdError + -- | Information about the source location where the record was updated. + -- + -- @ + -- '_RecUpdError' :: 'Prism'' 'RecUpdError' 'String' + -- '_RecUpdError' :: 'Prism'' 'SomeException' 'String' + -- @ _RecUpdError :: Prism' t String + _RecUpdError = __RecUpdError._RecUpdError + {-# INLINE _RecUpdError #-} instance AsRecUpdError RecUpdError where + __RecUpdError = id + {-# INLINE __RecUpdError #-} + _RecUpdError = _Wrapping RecUpdError {-# INLINE _RecUpdError #-} instance AsRecUpdError SomeException where - _RecUpdError = exception._Wrapping RecUpdError - {-# INLINE _RecUpdError #-} + __RecUpdError = exception + {-# INLINE __RecUpdError #-} #if __GLASGOW_HASKELL__ >= 710 +pattern RecUpdError__ e <- (preview __RecUpdError -> Just e) where + RecUpdError__ e = review __RecUpdError e + pattern RecUpdError_ e <- (preview _RecUpdError -> Just e) where RecUpdError_ e = review _RecUpdError e #endif @@ -1131,23 +1325,43 @@ -- | This is thrown when the user calls 'Prelude.error'. class AsErrorCall t where + -- | + -- @ + -- '__ErrorCall' :: 'Prism'' 'ErrorCall' 'ErrorCall' + -- '__ErrorCall' :: 'Prism'' 'SomeException' 'ErrorCall' + -- @ + __ErrorCall :: Prism' t ErrorCall + -- | Retrieve the argument given to 'Prelude.error'. -- -- 'ErrorCall' is isomorphic to a 'String'. -- -- >>> catching _ErrorCall (error "touch down!") return -- "touch down!" + -- + -- @ + -- '_ErrorCall' :: 'Prism'' 'ErrorCall' 'String' + -- '_ErrorCall' :: 'Prism'' 'SomeException' 'String' + -- @ _ErrorCall :: Prism' t String + _ErrorCall = __ErrorCall._ErrorCall + {-# INLINE _ErrorCall #-} instance AsErrorCall ErrorCall where + __ErrorCall = id + {-# INLINE __ErrorCall #-} + _ErrorCall = _Wrapping ErrorCall {-# INLINE _ErrorCall #-} instance AsErrorCall SomeException where - _ErrorCall = exception._Wrapping ErrorCall - {-# INLINE _ErrorCall #-} + __ErrorCall = exception + {-# INLINE __ErrorCall #-} #if __GLASGOW_HASKELL__ >= 710 +pattern ErrorCall__ e <- (preview __ErrorCall -> Just e) where + ErrorCall__ e = review __ErrorCall e + pattern ErrorCall_ e <- (preview _ErrorCall -> Just e) where ErrorCall_ e = review _ErrorCall e #endif @@ -1159,6 +1373,13 @@ -- | This thread has exceeded its allocation limit. class AsAllocationLimitExceeded t where + -- | + -- @ + -- '__AllocationLimitExceeded' :: 'Prism'' 'AllocationLimitExceeded' 'AllocationLimitExceeded' + -- '__AllocationLimitExceeded' :: 'Prism'' 'SomeException' 'AllocationLimitExceeded' + -- @ + __AllocationLimitExceeded :: Prism' t AllocationLimitExceeded + -- | There is no additional information carried in an -- 'AllocationLimitExceeded' 'Exception'. -- @@ -1167,15 +1388,23 @@ -- '_AllocationLimitExceeded' :: 'Prism'' 'SomeException' () -- @ _AllocationLimitExceeded :: Prism' t () + _AllocationLimitExceeded = __AllocationLimitExceeded._AllocationLimitExceeded + {-# INLINE _AllocationLimitExceeded #-} instance AsAllocationLimitExceeded AllocationLimitExceeded where + __AllocationLimitExceeded = id + {-# INLINE __AllocationLimitExceeded #-} + _AllocationLimitExceeded = trivial AllocationLimitExceeded {-# INLINE _AllocationLimitExceeded #-} instance AsAllocationLimitExceeded SomeException where - _AllocationLimitExceeded = exception.trivial AllocationLimitExceeded - {-# INLINE _AllocationLimitExceeded #-} + __AllocationLimitExceeded = exception + {-# INLINE __AllocationLimitExceeded #-} +pattern AllocationLimitExceeded__ e <- (preview __AllocationLimitExceeded -> Just e) where + AllocationLimitExceeded__ e = review __AllocationLimitExceeded e + pattern AllocationLimitExceeded_ <- (has _AllocationLimitExceeded -> True) where AllocationLimitExceeded_ = review _AllocationLimitExceeded () #endif @@ -1188,22 +1417,37 @@ -- | An expression that didn't typecheck during compile time was called. -- This is only possible with @-fdefer-type-errors@. class AsTypeError t where + -- | + -- @ + -- '__TypeError' :: 'Prism'' 'TypeError' 'TypeError' + -- '__TypeError' :: 'Prism'' 'SomeException' 'TypeError' + -- @ + __TypeError :: Prism' t TypeError + -- | Details about the failed type check. -- -- @ - -- '_TypeError' :: 'Prism'' 'TypeError' () - -- '_TypeError' :: 'Prism'' 'SomeException' () + -- '_TypeError' :: 'Prism'' 'TypeError' 'String' + -- '_TypeError' :: 'Prism'' 'SomeException' 'String' -- @ _TypeError :: Prism' t String + _TypeError = __TypeError._TypeError + {-# INLINE _TypeError #-} instance AsTypeError TypeError where + __TypeError = id + {-# INLINE __TypeError #-} + _TypeError = _Wrapping TypeError {-# INLINE _TypeError #-} instance AsTypeError SomeException where - _TypeError = exception._Wrapping TypeError - {-# INLINE _TypeError #-} + __TypeError = exception + {-# INLINE __TypeError #-} +pattern TypeError__ e <- (preview __TypeError -> Just e) where + TypeError__ e = review __TypeError e + pattern TypeError_ e <- (preview _TypeError -> Just e) where TypeError_ e = review _TypeError e #endif @@ -1216,22 +1460,37 @@ -- | Compaction found an object that cannot be compacted. -- Functions cannot be compacted, nor can mutable objects or pinned objects. class AsCompactionFailed t where + -- | + -- @ + -- '__CompactionFailed' :: 'Prism'' 'CompactionFailed' 'CompactionFailed' + -- '__CompactionFailed' :: 'Prism'' 'SomeException' 'CompactionFailed' + -- @ + __CompactionFailed :: Prism' t CompactionFailed + -- | Information about why a compaction failed. -- -- @ - -- '_CompactionFailed' :: 'Prism'' 'CompactionFailed' () - -- '_CompactionFailed' :: 'Prism'' 'SomeException' () + -- '_CompactionFailed' :: 'Prism'' 'CompactionFailed' 'String' + -- '_CompactionFailed' :: 'Prism'' 'SomeException' 'String' -- @ _CompactionFailed :: Prism' t String + _CompactionFailed = __CompactionFailed._CompactionFailed + {-# INLINE _CompactionFailed #-} instance AsCompactionFailed CompactionFailed where + __CompactionFailed = id + {-# INLINE __CompactionFailed #-} + _CompactionFailed = _Wrapping CompactionFailed {-# INLINE _CompactionFailed #-} instance AsCompactionFailed SomeException where - _CompactionFailed = exception._Wrapping CompactionFailed - {-# INLINE _CompactionFailed #-} + __CompactionFailed = exception + {-# INLINE __CompactionFailed #-} +pattern CompactionFailed__ e <- (preview __CompactionFailed -> Just e) where + CompactionFailed__ e = review __CompactionFailed e + pattern CompactionFailed_ e <- (preview _CompactionFailed -> Just e) where CompactionFailed_ e = review _CompactionFailed e #endif @@ -1243,6 +1502,13 @@ -- | This 'Exception' is thrown by @lens@ when the user somehow manages to rethrow -- an internal 'HandlingException'. class AsHandlingException t where + -- | + -- @ + -- '__HandlingException' :: 'Prism'' 'HandlingException' 'HandlingException' + -- '__HandlingException' :: 'Prism'' 'SomeException' 'HandlingException' + -- @ + __HandlingException :: Prism' t HandlingException + -- | There is no information carried in a 'HandlingException'. -- -- @ @@ -1250,16 +1516,24 @@ -- '_HandlingException' :: 'Prism'' 'SomeException' () -- @ _HandlingException :: Prism' t () + _HandlingException = __HandlingException._HandlingException + {-# INLINE _HandlingException #-} instance AsHandlingException HandlingException where + __HandlingException = id + {-# INLINE __HandlingException #-} + _HandlingException = trivial HandlingException {-# INLINE _HandlingException #-} instance AsHandlingException SomeException where - _HandlingException = exception.trivial HandlingException - {-# INLINE _HandlingException #-} + __HandlingException = exception + {-# INLINE __HandlingException #-} #if __GLASGOW_HASKELL__ >= 710 +pattern HandlingException__ e <- (preview __HandlingException -> Just e) where + HandlingException__ e = review __HandlingException e + pattern HandlingException_ <- (has _HandlingException -> True) where HandlingException_ = review _HandlingException () #endif 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 @@ -160,6 +160,14 @@ -- | @'each' :: 'Traversal' ('Maybe' a) ('Maybe' b) a b@ instance Each (Maybe a) (Maybe b) a b +-- | @'each' :: 'Traversal' ('Either' a a) ('Either' b b) a b@ +-- +-- @since 4.18 +instance (a~a', b~b') => Each (Either a a') (Either b b') a b where + each f (Left a) = Left <$> f a + each f (Right a ) = Right <$> f a + {-# INLINE each #-} + -- | @'each' :: 'Traversal' ('Seq' a) ('Seq' b) a b@ instance Each (Seq a) (Seq b) a b where each = traversed diff --git a/src/Control/Lens/Equality.hs b/src/Control/Lens/Equality.hs --- a/src/Control/Lens/Equality.hs +++ b/src/Control/Lens/Equality.hs @@ -2,9 +2,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Equality @@ -20,6 +25,7 @@ -- * Type Equality Equality, Equality' , AnEquality, AnEquality' + , (:~:)(..) , runEq , substEq , mapEq @@ -27,12 +33,26 @@ , simply -- * The Trivial Equality , simple + -- * 'Iso'-like functions + , equality + , equality' + , withEquality + , underEquality + , overEquality + , fromLeibniz + , fromLeibniz' + , cloneEquality -- * Implementation Details , Identical(..) ) where import Control.Lens.Type import Data.Proxy (Proxy) +import Data.Type.Equality ((:~:)(..)) +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Exts (TYPE) +import Data.Kind (Type) +#endif #ifdef HLINT {-# ANN module "HLint: ignore Use id" #-} @@ -68,14 +88,21 @@ {-# 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__ >= 706 -mapEq :: forall KVS(k1 k2) (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a +#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 @@ -89,7 +116,12 @@ -- | 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 #-} @@ -100,3 +132,60 @@ simple :: Equality' a a simple = id {-# INLINE simple #-} + +cloneEquality :: AnEquality s t a b -> Equality s t a b +cloneEquality an = substEq an id +{-# INLINE cloneEquality #-} + +-- | Construct an 'Equality' from explicit equality evidence. +equality :: s :~: a -> b :~: t -> Equality s t a b +equality Refl Refl = id +{-# INLINE equality #-} + +-- | A 'Simple' version of 'equality' +equality' :: a :~: b -> Equality' a b +equality' Refl = id +{-# INLINE equality' #-} + +-- | Recover a "profunctor lens" form of equality. Reverses 'fromLeibniz'. +overEquality :: AnEquality s t a b -> p a b -> p s t +overEquality an = substEq an id +{-# INLINE overEquality #-} + +-- | The opposite of working 'overEquality' is working 'underEquality'. +underEquality :: AnEquality s t a b -> p t s -> p b a +underEquality an = substEq an id +{-# INLINE underEquality #-} + +-- | Convert a "profunctor lens" form of equality to an equality. Reverses +-- 'overEquality'. +-- +-- The type should be understood as +-- +-- @fromLeibniz :: (forall p. p a b -> p s t) -> Equality s t a b@ +fromLeibniz :: (Identical a b a b -> Identical a b s t) -> Equality s t a b +fromLeibniz f = case f Identical of Identical -> id +{-# INLINE fromLeibniz #-} + +-- | Convert Leibniz equality to equality. Reverses 'mapEq' in 'Simple' cases. +-- +-- The type should be understood as +-- +-- @fromLeibniz' :: (forall f. f s -> f a) -> Equality' s a@ +fromLeibniz' :: (s :~: s -> s :~: a) -> Equality' s a +-- 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/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -68,6 +68,7 @@ , unfolded , iterated , filtered + , filteredBy , backwards , repeated , replicated @@ -163,7 +164,7 @@ import Control.Monad.State import Data.CallStack import Data.Foldable -import Data.Functor.Apply +import Data.Functor.Apply hiding ((<.)) import Data.Functor.Compose import Data.Functor.Contravariant import Data.Int (Int64) @@ -343,7 +344,7 @@ -- -- Note: This is /not/ a legal 'Traversal', unless you are very careful not to invalidate the predicate on the target. -- --- Note: This is also /not/ a legal 'Prism', unless you are very careful not to inject a value that matches the predicate. +-- Note: This is also /not/ a legal 'Prism', unless you are very careful not to inject a value that fails the predicate. -- -- As a counter example, consider that given @evens = 'filtered' 'even'@ the second 'Traversal' law is violated: -- @@ -361,6 +362,24 @@ filtered p = dimap (\x -> if p x then Right x else Left x) (either pure id) . right' {-# INLINE filtered #-} +-- | Obtain a potentially empty 'IndexedTraversal' by taking the first element from another, +-- potentially empty `Fold` and using it as an index. +-- +-- The resulting optic can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). +-- +-- >>> [(Just 2, 3), (Nothing, 4)] & mapped . filteredBy (_1 . _Just) <. _2 %@~ (*) :: [(Maybe Int, Int)] +-- [(Just 2,6),(Nothing,4)] +-- +-- @ +-- 'filteredBy' :: 'Fold' a i -> 'IndexedTraversal'' i a a +-- @ +-- +-- Note: As with 'filtered', this is /not/ a legal 'IndexedTraversal', unless you are very careful not to invalidate the predicate on the target! +filteredBy :: (Indexable i p, Applicative f) => Getting (First i) a i -> p a (f a) -> a -> f a +filteredBy p f val = case val ^? p of + Nothing -> pure val + Just witness -> indexed f witness val + -- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. -- -- @ @@ -1237,7 +1256,8 @@ -- way to extract the optional value. -- -- Note: if you get stack overflows due to this, you may want to use 'firstOf' instead, which can deal --- more gracefully with heavily left-biased trees. +-- more gracefully with heavily left-biased trees. This is because '^?' works by using the +-- 'Data.Monoid.First' monoid, which can occasionally cause space leaks. -- -- >>> Left 4 ^?_Left -- Just 4 @@ -1251,10 +1271,15 @@ -- >>> "world" ^? ix 20 -- Nothing -- +-- This operator works as an infix version of 'preview'. +-- -- @ -- ('^?') ≡ 'flip' 'preview' -- @ -- +-- It may be helpful to think of '^?' as having one of the following +-- more specialized types: +-- -- @ -- ('^?') :: s -> 'Getter' s a -> 'Maybe' a -- ('^?') :: s -> 'Fold' s a -> 'Maybe' a @@ -1288,9 +1313,11 @@ -- | Retrieve the 'First' entry of a 'Fold' or 'Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. -- --- The answer is computed in a manner that leaks space less than @'ala' 'First' '.' 'foldMapOf'@ --- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse --- constant factors. +-- The answer is computed in a manner that leaks space less than @'preview'@ or @^?'@ +-- and gives you back access to the outermost 'Just' constructor more quickly, but does so +-- in a way that builds an intermediate structure, and thus may have worse +-- constant factors. This also means that it can not be used in any 'Control.Monad.Reader.MonadReader', +-- but must instead have 's' passed as its last argument, unlike 'preview'. -- -- Note: this could been named `headOf`. -- @@ -1951,19 +1978,33 @@ ------------------------------------------------------------------------------ -- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result --- from a 'Getter' or 'Lens'). See also ('^?'). +-- from a 'Getter' or 'Lens'). See also 'firstOf' and '^?', which are similar with +-- some subtle differences (explained below). -- -- @ -- 'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded' -- @ -- --- This is usually applied in the 'Control.Monad.Reader.Reader' --- 'Control.Monad.Monad' @(->) s@. --- -- @ -- 'preview' = 'view' '.' 'pre' -- @ +-- -- +-- Unlike '^?', this function uses a +-- 'Control.Monad.Reader.MonadReader' to read the value to be focused in on. +-- This allows one to pass the value as the last argument by using the +-- 'Control.Monad.Reader.MonadReader' instance for @(->) s@ +-- However, it may also be used as part of some deeply nested transformer stack. +-- +-- 'preview' uses a monoidal value to obtain the result. +-- This means that it generally has good performance, but can occasionally cause space leaks +-- or even stack overflows on some data types. +-- There is another function, 'firstOf', which avoids these issues at the cost of +-- a slight constant performance cost and a little less flexibility. +-- +-- It may be helpful to think of 'preview' as having one of the following +-- more specialized types: +-- -- @ -- 'preview' :: 'Getter' s a -> s -> 'Maybe' a -- 'preview' :: 'Fold' s a -> s -> 'Maybe' a @@ -1972,8 +2013,6 @@ -- 'preview' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ -- --- However, it may be useful to think of its full generality when working with --- a 'Control.Monad.Monad' transformer stack: -- -- @ -- 'preview' :: 'MonadReader' s m => 'Getter' s a -> m ('Maybe' a) @@ -1981,6 +2020,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)) 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 @@ -105,16 +105,30 @@ instance Functor (Bazaar p a b) where fmap = ifmap {-# INLINE fmap #-} + x <$ Bazaar k = Bazaar ( (x <$) . k ) + {-# INLINE (<$) #-} instance Apply (Bazaar p a b) where - Bazaar mf <.> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb + (<.>) = (<*>) {-# INLINE (<.>) #-} + (.>) = (*>) + {-# INLINE (.>) #-} + (<.) = (<*) + {-# INLINE (<.) #-} instance Applicative (Bazaar p a b) where pure a = Bazaar $ \_ -> pure a {-# INLINE pure #-} Bazaar mf <*> Bazaar ma = Bazaar $ \ pafb -> mf pafb <*> ma pafb {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 f (Bazaar mx) (Bazaar my) = Bazaar $ \pafb -> liftA2 f (mx pafb) (my pafb) + {-# INLINE liftA2 #-} +#endif + Bazaar mx *> Bazaar my = Bazaar $ \pafb -> mx pafb *> my pafb + {-# INLINE (*>) #-} + Bazaar mx <* Bazaar my = Bazaar $ \pafb -> mx pafb <* my pafb + {-# INLINE (<*) #-} instance (a ~ b, Conjoined p) => Comonad (Bazaar p a b) where extract = iextract @@ -125,6 +139,10 @@ instance (a ~ b, Conjoined p) => ComonadApply (Bazaar p a b) where (<@>) = (<*>) {-# INLINE (<@>) #-} + (@>) = (*>) + {-# INLINE (@>) #-} + (<@) = (<*) + {-# INLINE (<@) #-} ------------------------------------------------------------------------------ -- BazaarT @@ -168,16 +186,30 @@ instance Functor (BazaarT p g a b) where fmap = ifmap {-# INLINE fmap #-} + x <$ BazaarT k = BazaarT ( (x <$) . k ) + {-# INLINE (<$) #-} instance Apply (BazaarT p g a b) where - BazaarT mf <.> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb + (<.>) = (<*>) {-# INLINE (<.>) #-} + (.>) = (*>) + {-# INLINE (.>) #-} + (<.) = (<*) + {-# INLINE (<.) #-} instance Applicative (BazaarT p g a b) where pure a = BazaarT $ tabulate $ \_ -> pure (pure a) {-# INLINE pure #-} BazaarT mf <*> BazaarT ma = BazaarT $ \ pafb -> mf pafb <*> ma pafb {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 f (BazaarT mx) (BazaarT my) = BazaarT $ \pafb -> liftA2 f (mx pafb) (my pafb) + {-# INLINE liftA2 #-} +#endif + BazaarT mf *> BazaarT ma = BazaarT $ \ pafb -> mf pafb *> ma pafb + {-# INLINE (*>) #-} + BazaarT mf <* BazaarT ma = BazaarT $ \ pafb -> mf pafb <* ma pafb + {-# INLINE (<*) #-} instance (a ~ b, Conjoined p) => Comonad (BazaarT p g a b) where extract = iextract @@ -188,6 +220,10 @@ instance (a ~ b, Conjoined p) => ComonadApply (BazaarT p g a b) where (<@>) = (<*>) {-# INLINE (<@>) #-} + (@>) = (*>) + {-# INLINE (@>) #-} + (<@) = (<*) + {-# INLINE (<@) #-} instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where contramap _ = (<$) (error "contramap: BazaarT") @@ -261,10 +297,16 @@ instance Functor (Bazaar1 p a b) where fmap = ifmap {-# INLINE fmap #-} + x <$ Bazaar1 k = Bazaar1 ((x <$) . k) + {-# INLINE (<$) #-} instance Apply (Bazaar1 p a b) where Bazaar1 mf <.> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb {-# INLINE (<.>) #-} + Bazaar1 mf .> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb .> ma pafb + {-# INLINE (.>) #-} + Bazaar1 mf <. Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <. ma pafb + {-# INLINE (<.) #-} instance (a ~ b, Conjoined p) => Comonad (Bazaar1 p a b) where extract = iextract @@ -273,8 +315,12 @@ {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (Bazaar1 p a b) where - Bazaar1 mf <@> Bazaar1 ma = Bazaar1 $ \ pafb -> mf pafb <.> ma pafb + (<@>) = (<.>) {-# INLINE (<@>) #-} + (@>) = (.>) + {-# INLINE (@>) #-} + (<@) = (<.) + {-# INLINE (<@) #-} ------------------------------------------------------------------------------ -- BazaarT1 @@ -318,10 +364,16 @@ instance Functor (BazaarT1 p g a b) where fmap = ifmap {-# INLINE fmap #-} + x <$ BazaarT1 k = BazaarT1 ((x <$) . k) + {-# INLINE (<$) #-} instance Apply (BazaarT1 p g a b) where BazaarT1 mf <.> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb {-# INLINE (<.>) #-} + BazaarT1 mf .> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb .> ma pafb + {-# INLINE (.>) #-} + BazaarT1 mf <. BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <. ma pafb + {-# INLINE (<.) #-} instance (a ~ b, Conjoined p) => Comonad (BazaarT1 p g a b) where extract = iextract @@ -330,8 +382,12 @@ {-# INLINE duplicate #-} instance (a ~ b, Conjoined p) => ComonadApply (BazaarT1 p g a b) where - BazaarT1 mf <@> BazaarT1 ma = BazaarT1 $ \ pafb -> mf pafb <.> ma pafb + (<@>) = (<.>) {-# INLINE (<@>) #-} + (@>) = (.>) + {-# INLINE (@>) #-} + (<@) = (<.) + {-# INLINE (<@) #-} instance (Profunctor p, Contravariant g) => Contravariant (BazaarT1 p g a b) where contramap _ = (<$) (error "contramap: BazaarT1") diff --git a/src/Control/Lens/Internal/ByteString.hs b/src/Control/Lens/Internal/ByteString.hs --- a/src/Control/Lens/Internal/ByteString.hs +++ b/src/Control/Lens/Internal/ByteString.hs @@ -59,13 +59,11 @@ import Foreign.Storable #if MIN_VERSION_base(4,8,0) import Foreign.ForeignPtr -#elif MIN_VERSION_base(4,4,0) +#else import Foreign.ForeignPtr.Safe +#endif #if !MIN_VERSION_bytestring(0,10,4) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -#endif -#else -import Foreign.ForeignPtr #endif import GHC.Base (unsafeChr) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) 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 @@ -67,6 +67,9 @@ -- "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 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 @@ -176,7 +176,11 @@ -- 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)] + typeOf _ = mkTyConApp handlingTyCon + [ typeOf (undefined :: a) + , typeOf (undefined :: s) + , typeOf1 (undefined :: m a) + ] {-# INLINE typeOf #-} handlingTyCon :: TyCon 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 @@ -105,6 +105,31 @@ -- Generate an "As" class of prisms. Names are selected by prefixing the constructor -- name with an underscore. Constructors with multiple fields will -- construct Prisms to tuples of those fields. +-- +-- In the event that the name of a data type is also the name of one of its +-- constructors, the name of the 'Prism' generated for the data type will be +-- prefixed with an extra @_@ (if the data type name is prefix) or @.@ (if the +-- name is infix) to disambiguate it from the 'Prism' for the corresponding +-- constructor. For example, this code: +-- +-- @ +-- data Quux = Quux Int | Fred Bool +-- makeClassyPrisms ''Quux +-- @ +-- +-- will create: +-- +-- @ +-- class AsQuux s where +-- __Quux :: Prism' s Quux -- Data type prism +-- _Quux :: Prism' s Int -- Constructor prism +-- _Fred :: Prism' s Bool +-- +-- _Quux = __Quux . _Quux +-- _Fred = __Quux . _Fred +-- +-- instance AsQuux Quux +-- @ makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ makeClassyPrisms = makePrisms' False @@ -145,9 +170,11 @@ stab <- computeOpticType t cons con let n = prismName conName sequenceA - [ sigD n (close (stabToType stab)) - , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] - ] + ( [ sigD n (close (stabToType stab)) + , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] + ] + ++ inlinePragma n + ) -- classy prism class and instance @@ -157,8 +184,10 @@ , makeClassyPrismInstance t className methodName cons ] where - className = mkName ("As" ++ nameBase typeName) - methodName = prismName typeName + typeNameBase = nameBase typeName + className = mkName ("As" ++ typeNameBase) + sameNameAsCon = any (\con -> nameBase (view nconName con) == typeNameBase) cons + methodName = prismName' sameNameAsCon typeName data OpticType = PrismType | ReviewType @@ -249,9 +278,11 @@ do let ty = computeIsoType s (view nconTypes con) defName = prismName (view nconName con) sequenceA - [ sigD defName ty - , valD (varP defName) (normalB (makeConIsoExp con)) [] - ] + ( [ sigD defName ty + , valD (varP defName) (normalB (makeConIsoExp con)) [] + ] ++ + inlinePragma defName + ) -- | Construct prism expression @@ -269,7 +300,7 @@ conName = view nconName con reviewer = makeReviewer conName fields - remitter | stabSimple stab = makeSimpleRemitter conName fields + remitter | stabSimple stab = makeSimpleRemitter conName (length cons) fields | otherwise = makeFullRemitter cons conName @@ -320,15 +351,22 @@ -- Con x y z -> Right (x,y,z) -- _ -> Left x -- ) :: s -> Either s a -makeSimpleRemitter :: Name -> Int -> ExpQ -makeSimpleRemitter conName fields = +makeSimpleRemitter :: + Name {- The name of the constructor on which this prism focuses -} -> + Int {- The number of constructors the parent data type has -} -> + Int {- The number of fields the constructor has -} -> + ExpQ +makeSimpleRemitter conName numCons fields = do x <- newName "x" xs <- newNames "y" fields let matches = [ match (conP conName (map varP xs)) (normalB (appE (conE rightDataName) (toTupleE (map varE xs)))) [] - , match wildP (normalB (appE (conE leftDataName) (varE x))) [] + ] ++ + [ match wildP (normalB (appE (conE leftDataName) (varE x))) [] + | numCons > 1 -- Only generate a catch-all case if there is at least + -- one constructor besides the one being focused on. ] lam1E (varP x) (caseE (varE x) matches) @@ -478,11 +516,35 @@ -- | Compute a prism's name by prefixing an underscore for normal -- constructors and period for operators. prismName :: Name -> Name -prismName n = case nameBase n of - [] -> error "prismName: empty name base?" - x:xs | isUpper x -> mkName ('_':x:xs) - | otherwise -> mkName ('.':x:xs) -- operator +prismName = prismName' False +-- | Compute a prism's name with a special case for when the type +-- constructor matches one of the value constructors. +-- +-- The overlapping flag wil be 'True' in the event that: +-- +-- 1. We are generating the name of a classy prism for a +-- data type, and +-- 2. The data type shares a name with one of its +-- constructors (e.g., @data A = A@). +-- +-- In such a scenario, we take care not to generate the same +-- prism name that the constructor receives (e.g., @_A@). +-- For prefix names, we accomplish this by adding an extra +-- underscore; for infix names, an extra dot. +prismName' :: + Bool {- ^ overlapping constructor -} -> + Name {- ^ type constructor -} -> + Name {- ^ prism name -} +prismName' sameNameAsCon n = + case nameBase n of + [] -> error "prismName: empty name base?" + nb@(x:_) | isUpper x -> mkName (prefix '_' nb) + | otherwise -> mkName (prefix '.' nb) -- operator + where + prefix :: Char -> String -> String + prefix char str | sameNameAsCon = char:char:str + | otherwise = char:str -- | Quantify all the free variables in a type. close :: Type -> TypeQ 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 @@ -7,10 +7,6 @@ # endif #endif -#ifdef HLINT -{-# ANN module "HLint: ignore Use camelCase" #-} -#endif - #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) #endif @@ -44,14 +40,6 @@ import Paths_lens (version) #endif --- | Compatibility shim for recent changes to template haskell's 'tySynInstD' -tySynInstD' :: Name -> [TypeQ] -> TypeQ -> DecQ -#if MIN_VERSION_template_haskell(2,9,0) -tySynInstD' fam ts r = tySynInstD fam (tySynEqn ts r) -#else -tySynInstD' = tySynInstD -#endif - -- | Apply arguments to a type constructor appsT :: TypeQ -> [TypeQ] -> TypeQ appsT = foldl appT @@ -95,6 +83,34 @@ -- | Generate many new names from a given base name. newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] newNames base n = sequence [ newName (base++show i) | i <- [1..n] ] + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Either Int Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char]) +-- @ +-- +-- This function ignores explicit parentheses and visible kind applications. +unfoldType :: Type -> (Type, [Type]) +unfoldType = go [] + where + go :: [Type] -> Type -> (Type, [Type]) + go acc (ForallT _ _ ty) = go acc ty + go acc (AppT ty1 ty2) = go (ty2:acc) ty1 + go acc (SigT ty _) = go acc ty +#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 diff --git a/src/Control/Lens/Internal/Typeable.hs b/src/Control/Lens/Internal/Typeable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/Typeable.hs @@ -0,0 +1,24 @@ +{-# 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/Iso.hs b/src/Control/Lens/Iso.hs --- a/src/Control/Lens/Iso.hs +++ b/src/Control/Lens/Iso.hs @@ -2,6 +2,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-} @@ -9,6 +10,10 @@ {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif + #ifndef MIN_VERSION_bytestring #define MIN_VERSION_bytestring(x,y,z) 1 #endif @@ -20,7 +25,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional --- Portability : Rank2Types +-- Portability : Rank2Types, TypeFamilies, FunctionalDependencies -- ---------------------------------------------------------------------------- module Control.Lens.Iso @@ -37,6 +42,8 @@ -- * Working with isomorphisms , au , auf + , xplat + , xplatf , under , mapping -- ** Common Isomorphisms @@ -99,16 +106,21 @@ import Control.Lens.Type import Control.Monad.State.Lazy as Lazy import Control.Monad.State.Strict as Strict -import Control.Monad.Writer.Lazy as Lazy -import Control.Monad.Writer.Strict as Strict -import Control.Monad.RWS.Lazy as Lazy -import Control.Monad.RWS.Strict as Strict +import 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.Functor.Identity import Data.Text as StrictT hiding (reverse) import Data.Text.Lazy as LazyT hiding (reverse) @@ -117,6 +129,10 @@ 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 @@ -128,6 +144,10 @@ 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 @@ -172,12 +192,17 @@ -- 'from' ('from' l) ≡ l -- @ from :: AnIso s t a b -> Iso b a t s -from l = withIso l $ \ sa bt -> iso bt sa +from l = withIso l $ flip iso {-# 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 #-} @@ -208,6 +233,10 @@ -- @ -- au :: AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a -- @ +-- +-- @ +-- au = xplat . from +-- @ au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a au k = withIso k $ \ sa bt f -> fmap sa (f bt) {-# INLINE au #-} @@ -218,21 +247,41 @@ -- -- For a version you pass the name of the @newtype@ constructor to, see 'Control.Lens.Wrapped.alaf'. -- --- >>> auf (_Unwrapping Sum) (foldMapOf both) Prelude.length ("hello","world") +-- >>> auf (_Wrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10 -- -- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator -- is 'au' with an extra function argument: -- -- @ --- 'auf' :: 'Iso' s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t +-- 'auf' :: 'Iso' s t a b -> ((r -> t) -> e -> s) -> (r -> b) -> e -> a -- @ -- -- but the signature is general. -auf :: Optic (Costar f) g s t a b -> (f a -> g b) -> f s -> g t -auf = coerce +-- +-- Note: The direction of the 'Iso' required for this function changed in @lens@ 4.18 to match up +-- with the behavior of 'au'. For the old behavior use 'xplatf' or for a version that is compatible +-- across both old and new versions of @lens@ you can just use 'coerce'! +auf :: (Functor f, Functor g) => AnIso s t a b -> (f t -> g s) -> f b -> g a +auf k ftgs fb = withIso k $ \sa bt -> sa <$> ftgs (bt <$> fb) {-# INLINE auf #-} +-- | @'xplat' = 'au' . 'from'@ but with a nicer signature. +xplat :: Optic (Costar ((->) s)) g s t a b -> ((s -> a) -> g b) -> g t +xplat f g = xplatf f g id + +-- | @'xplatf' = 'auf' . 'from'@ but with a nicer signature. +-- +-- >>> xplatf (_Unwrapping Sum) (foldMapOf both) Prelude.length ("hello","world") +-- 10 +-- +-- @ +-- 'xplatf' :: 'Iso' s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t +-- @ +xplatf :: Optic (Costar f) g s t a b -> (f a -> g b) -> f s -> g t +xplatf = coerce +{-# INLINE xplat #-} + -- | The opposite of working 'Control.Lens.Setter.over' a 'Setter' is working 'under' an isomorphism. -- -- @ @@ -408,6 +457,57 @@ 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) -- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure, -- such as 'StrictT.Text' or 'StrictB.ByteString'. 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,6 +6,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 @@ -70,7 +73,7 @@ , AnIndexedLens, AnIndexedLens' -- * Combinators - , lens, ilens, iplens + , lens, ilens, iplens, withLens , (%%~), (%%=) , (%%@~), (%%@=) , (<%@~), (<%@=) @@ -118,6 +121,7 @@ -- * Common Lenses , devoid , united + , head1, last1 -- * Context , Context(..) @@ -136,12 +140,15 @@ import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.State as State +import Data.Functor.Apply +import Data.Functor.Reverse import Data.Functor.Yoneda import Data.Monoid import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Unsafe +import Data.Semigroup.Traversable import Data.Void import Prelude #if MIN_VERSION_base(4,8,0) @@ -150,6 +157,9 @@ #if MIN_VERSION_base(4,11,0) import Data.Functor ((<&>)) #endif +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Exts (TYPE) +#endif #ifdef HLINT {-# ANN module "HLint: ignore Use ***" #-} @@ -160,6 +170,8 @@ -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Char (chr) +-- >>> import Data.List.NonEmpty (NonEmpty ((:|))) +-- >>> import Data.Tree (Tree (Node)) -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f @@ -226,6 +238,16 @@ lens sa sbt afb s = sbt s <$> afb (sa s) {-# 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 #-} + -- | Build an index-preserving 'Lens' from a 'Control.Lens.Getter.Getter' and a -- 'Control.Lens.Setter.Setter'. iplens :: (s -> a) -> (s -> b -> t) -> IndexPreservingLens s t a b @@ -1496,6 +1518,42 @@ united :: Lens' a () united f v = f () <&> \ () -> v {-# INLINE united #-} + +data First1 f a = First1 (f a) a + +instance (Functor f) => Functor (First1 f) where + fmap f (First1 fa a) = First1 (f <$> fa) (f a) + {-# INLINE fmap #-} + +instance (Functor f) => Apply (First1 f) where + First1 ff f <.> First1 _ x = First1 (($ x) <$> ff) (f x) + {-# INLINE (<.>) #-} + +getFirst1 :: First1 f a -> f a +getFirst1 (First1 fa _) = fa +{-# INLINE getFirst1 #-} + +-- | A 'Lens' focusing on the first element of a 'Traversable1' container. +-- +-- >>> 2 :| [3, 4] & head1 +~ 10 +-- 12 :| [3,4] +-- +-- >>> Identity True ^. head1 +-- True +head1 :: (Traversable1 t) => Lens' (t a) a +head1 f = getFirst1 . traverse1 (\a -> First1 (f a) a) +{-# INLINE head1 #-} + +-- | A 'Lens' focusing on the last element of a 'Traversable1' container. +-- +-- >>> 2 :| [3, 4] & last1 +~ 10 +-- 2 :| [3,14] +-- +-- >>> Node 'a' [Node 'b' [], Node 'c' []] ^. last1 +-- 'c' +last1 :: (Traversable1 t) => Lens' (t a) a +last1 f = fmap getReverse . head1 f . Reverse +{-# INLINE last1 #-} -- | Fuse a composition of lenses using 'Yoneda' to provide 'fmap' fusion. -- 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 @@ -198,6 +198,11 @@ -- -- >>> isn't _Empty [] -- False +-- +-- @ +-- 'isn't' = 'not' . 'Control.Lens.Extra.is' +-- 'isn't' = 'hasn't' +-- @ isn't :: APrism s t a b -> s -> Bool isn't k s = case matching k s of 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 @@ -116,6 +116,7 @@ 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.Syntax hiding (lift) @@ -512,11 +513,16 @@ , 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 _ -> Just DataDecl + cons _ +#endif + -> Just DataDecl { dataContext = ctx , tyConName = Nothing , dataParameters = map PlainTV vars @@ -533,6 +539,13 @@ -- -- 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. @@ -609,7 +622,8 @@ let appliedType = fullType dataDecl (map VarT typeArgs) -- type Unwrapped (Con a b c...) = $fieldType - let unwrappedATF = tySynInstD' unwrappedTypeName [return appliedType] (return fieldType) + let unwrappedATF = tySynInstDCompat unwrappedTypeName Nothing + [return appliedType] (return fieldType) -- Wrapped (Con a b c...) let klass = conT wrappedTypeName `appT` return appliedType 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 @@ -146,9 +146,6 @@ import Control.Monad.Trans.State.Lazy import Data.Bitraversable import Data.CallStack -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (Foldable) -#endif import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Day.Curried @@ -160,13 +157,12 @@ import Data.Map (Map) import Data.Sequence (Seq, mapWithIndex) import Data.Vector as Vector (Vector, imap) -import Data.Monoid (Monoid (..), Any (..), Endo (..)) +import Data.Monoid (Any (..), Endo (..)) import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Data.Reflection -import Data.Semigroup (Semigroup (..)) import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable import Data.Traversable @@ -174,6 +170,15 @@ import GHC.Magic (inline) import Prelude hiding ((.),id) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable (Foldable) +import Data.Monoid (Monoid (..)) +#endif + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup (..)) +#endif + -- $setup -- >>> :set -XNoOverloadedStrings -XFlexibleContexts -- >>> import Data.Char (toUpper) @@ -737,11 +742,11 @@ runHoles (runBazaar (f sell xs) (cotabulate holeInOne)) id {-# INLINE holesOf #-} -holeInOne :: forall p a t. (Corepresentable p, Category p) +holeInOne :: (Corepresentable p, Comonad (Corep p)) => Corep p a -> Holes t (Endo [Pretext p a a t]) a holeInOne x = Holes $ \xt -> ( Endo (fmap xt (cosieve sell x) :) - , cosieve (id :: p a a) x) + , extract x) {-# INLINABLE holeInOne #-} -- | The non-empty version of 'holesOf'. @@ -821,7 +826,8 @@ -- | Traverse both parts of a 'Bitraversable' container with matching types. -- --- Usually that type will be a pair. +-- Usually that type will be a pair. Use 'Control.Lens.Each.each' to traverse +-- the elements of arbitrary homogeneous tuples. -- -- >>> (1,2) & both *~ 10 -- (10,20) 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 @@ -401,7 +401,7 @@ -- 'Control.Lens.Fold.lengthOf' l x '<=' 1 -- @ -- --- It may help to think of this as a 'Iso' that can be partial in one direction. +-- It may help to think of this as an 'Iso' that can be partial in one direction. -- -- Every 'Prism' is a valid 'Traversal'. -- 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 @@ -26,14 +26,15 @@ -- -- One commonly asked question is: can we combine two lenses, -- @`Lens'` a b@ and @`Lens'` a c@ into @`Lens'` a (b, c)@. --- This is fair thing to ask, but such operation is unsound in general. +-- This is fair thing to ask, but such operation is unsound in general. -- See `lensProduct`. -- ------------------------------------------------------------------------------- module Control.Lens.Unsound - ( + ( lensProduct , prismSum + , adjoin ) where import Control.Applicative @@ -41,7 +42,7 @@ import Prelude -- | 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 'Lens' if the input lenses project disjoint parts of -- the structure @s@. Otherwise "you get what you put in" law -- -- @ @@ -77,7 +78,7 @@ -- Just (Left 'x') -- -- We put in 'Right' value, but get back 'Left'. --- +-- -- Are you looking for 'Control.Lens.Prism.without'? -- prismSum :: APrism s t a b @@ -90,4 +91,14 @@ f (Left <$> seta s) (Right <$> setb s) where f a@(Right _) _ = a - f (Left _) b = b + f (Left _) b = b + +-- | A generalization of `mappend`ing folds: A union of disjoint traversals. +-- +-- Traversing the same entry twice is illegal. +-- +-- Are you looking for 'Control.Lens.Traversal.failing'? +-- +adjoin :: Traversal' s a -> Traversal' s a -> Traversal' s a +adjoin t1 t2 = + lensProduct (partsOf t1) (partsOf t2) . both . each diff --git a/src/Control/Lens/Wrapped.hs b/src/Control/Lens/Wrapped.hs --- a/src/Control/Lens/Wrapped.hs +++ b/src/Control/Lens/Wrapped.hs @@ -1359,7 +1359,7 @@ -- @ ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s) -ala = au . _Wrapping +ala = xplat . _Unwrapping {-# INLINE ala #-} -- | This combinator is based on @ala'@ from Conor McBride's work on Epigram. @@ -1367,11 +1367,11 @@ -- As with '_Wrapping', the user supplied function for the newtype is /ignored/. -- -- @ --- alaf :: Rewrapping s t => (Unwrapped s -> s) -> ((r -> t) -> e -> s) -> (r -> Unwrapped t) -> e -> Unwrapped s +-- alaf :: Rewrapping s t => (Unwrapped s -> s) -> ((r -> t) -> e -> s) -> (r -> Unwrapped t) -> e -> Unwrapped s -- @ -- -- >>> alaf Sum foldMap Prelude.length ["hello","world"] -- 10 alaf :: (Functor f, Functor g, Rewrapping s t) => (Unwrapped s -> s) -> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s) -alaf = auf . _Unwrapping +alaf = xplatf . _Unwrapping {-# 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,8 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} #ifndef MIN_VERSION_mtl @@ -197,7 +199,7 @@ {-# 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) . liftM getFreed . zoom (\afb -> unfocusingFree #.. l (FocusingFree #.. afb)) . liftM Freed . runFreeT + zoom l = FreeT . liftM (fmap (zoom l) . getFreed) . zoom (\afb -> unfocusingFree #.. l (FocusingFree #.. afb)) . liftM Freed . runFreeT ------------------------------------------------------------------------------ -- Magnify @@ -227,7 +229,16 @@ -- >>> flip Reader.runReader (1,2,[10..20]) $ magnify (_3._tail) Reader.ask -- [11,12,13,14,15,16,17,18,19,20] -- + -- The type can be read as + -- -- @ + -- magnify :: LensLike' (Magnified m c) a b -> m c -> n c + -- @ + -- + -- but the higher-rank constraints make it easier to apply @magnify@ to a + -- 'Getter' in highly-polymorphic code. + -- + -- @ -- 'magnify' :: 'Getter' s a -> (a -> r) -> s -> r -- 'magnify' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r -- @ @@ -237,8 +248,11 @@ -- 'magnify' :: ('Monoid' w, 'Monoid' c) => 'Fold' s a -> 'RWS' a w st c -> 'RWS' s w st c -- ... -- @ - magnify :: LensLike' (Magnified m c) a b -> m c -> n c + magnify :: ((Functor (Magnified m c), Contravariant (Magnified m c)) + => LensLike' (Magnified m c) a b) + -> m c -> n c + instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where magnify l (ReaderT m) = ReaderT $ getEffect #. l (Effect #. m) {-# INLINE magnify #-} @@ -247,7 +261,7 @@ -- 'magnify' = 'views' -- @ instance Magnify ((->) b) ((->) a) b a where - magnify = views + magnify l = views l {-# INLINE magnify #-} instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) b a where 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 @@ -35,8 +35,10 @@ import Control.Monad.Error.Class import Data.Functor.Plus import qualified Data.Monoid as M + +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) -import Prelude +#endif #ifdef HLINT {-# ANN module "HLint: ignore Use fmap" #-} 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 @@ -159,18 +159,70 @@ l <.|.= b = l <%= (.|. b) {-# INLINE (<.|.=) #-} +-- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', and return the +-- original value, or a monoidal summary of the original values. +-- +-- When you do not need the old value, ('.&.~') is more flexible. +-- +-- >>> _2 <<.&.~ 7 $ ("hello", 254) +-- (254,("hello",6)) +-- +-- @ +-- ('<<.&.~') :: 'Bits' a => '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 => 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 +-- original value, or a monoidal summary of the original values. +-- +-- When you do not need the old value, ('.|.~') is more flexible. +-- +-- >>> _2 <<.|.~ 6 $ ("hello", 3) +-- (3,("hello",7)) +-- +-- @ +-- ('<<.|.~') :: 'Bits' a => '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 => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.|.~ b = l $ \a -> (a, a .|. b) {-# INLINE (<<.|.~) #-} +-- | Modify the target(s) of a 'Lens'', (or 'Traversal'') by computing its +-- bitwise '.&.' with another value, returning the original value (or a +-- monoidal summary of all the original values). +-- +-- When you do not need the old value, ('.&.=') is more flexible. +-- +-- >>> runState (_1 <<.&.= 15) (31,0) +-- (31,(15,0)) +-- +-- @ +-- ('<<.&.=') :: ('MonadState' s m, 'Bits' a) => 'Lens'' s a -> a -> m a +-- ('<<.&.=') :: ('MonadState' s m, 'Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal'' s a -> a -> m a +-- @ (<<.&.=) :: (MonadState s m, Bits a) => LensLike' ((,) a) s a -> a -> m a l <<.&.= b = l %%= \a -> (a, a .&. b) {-# INLINE (<<.&.=) #-} +-- | Modify the target(s) of a 'Lens'', (or 'Traversal'') by computing its +-- bitwise '.|.' with another value, returning the original value (or a +-- monoidal summary of all the original values). +-- +-- When you do not need the old value, ('.|.=') is more flexible. +-- +-- >>> runState (_1 <<.|.= 7) (28,0) +-- (28,(31,0)) +-- +-- @ +-- ('<<.|.=') :: ('MonadState' s m, 'Bits' a) => 'Lens'' s a -> a -> m a +-- ('<<.|.=') :: ('MonadState' s m, 'Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal'' s a -> a -> m a +-- @ (<<.|.=) :: (MonadState s m, Bits a) => LensLike' ((,) a) s a -> a -> m a l <<.|.= b = l %%= \a -> (a, a .|. b) {-# INLINE (<<.|.=) #-} 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 @@ -5,6 +5,7 @@ {-# LANGUAGE UnboxedTuples #-} #endif {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -66,6 +67,10 @@ import GHC.Exts (realWorld#) import Prelude +import qualified Data.Proxy as X (Proxy (..)) +import qualified Control.Lens.Internal.Typeable as X +import qualified Data.Type.Equality as X + #ifdef HLINT {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Use foldl" #-} @@ -102,8 +107,8 @@ {-# INLINE tinplate #-} step :: forall s a f r. (Applicative f, Typeable a, Data s) => (a -> f a) -> f (s -> r) -> s -> f r -step f w s = w <*> case mightBe :: Maybe (Is s a) of - Just Data.Data.Lens.Refl -> f s +step f w s = w <*> case X.eqT :: Maybe (s X.:~: a) of + Just X.Refl -> f s Nothing -> tinplate f s {-# INLINE step #-} @@ -263,17 +268,6 @@ {-# INLINE onceUpon' #-} ------------------------------------------------------------------------------- --- Type equality -------------------------------------------------------------------------------- - -data Is a b where - Refl :: Is a a - -mightBe :: (Typeable a, Typeable b) => Maybe (Is a b) -mightBe = gcast Data.Data.Lens.Refl -{-# INLINE mightBe #-} - -------------------------------------------------------------------------------- -- Data Box ------------------------------------------------------------------------------- @@ -283,7 +277,7 @@ } dataBox :: Data a => a -> DataBox -dataBox a = DataBox (typeOf a) a +dataBox a = DataBox (X.typeRep [a]) a {-# INLINE dataBox #-} -- partial, caught elsewhere @@ -307,8 +301,8 @@ [ (tRational, S.singleton tInteger) , (tInteger, S.empty) ] where - tRational = typeOf (undefined :: Rational) - tInteger = typeOf (undefined :: Integer ) + tRational = X.typeRep (X.Proxy :: X.Proxy Rational) + tInteger = X.typeRep (X.Proxy :: X.Proxy Integer ) insertHitMap :: DataBox -> HitMap -> HitMap insertHitMap box hit = fixEq trans (populate box) `mappend` hit where @@ -389,8 +383,8 @@ hitTest :: forall a b. (Data a, Typeable b) => a -> b -> Oracle b hitTest a b = Oracle $ \(c :: c) -> - case mightBe :: Maybe (Is c b) of - Just Data.Data.Lens.Refl -> Hit c + case X.eqT :: Maybe (c X.:~: b) of + Just X.Refl -> Hit c Nothing -> case readCacheFollower (dataBox a) (typeOf b) of Just p | not (p (typeOf c)) -> Miss diff --git a/src/Data/HashSet/Lens.hs b/src/Data/HashSet/Lens.hs --- a/src/Data/HashSet/Lens.hs +++ b/src/Data/HashSet/Lens.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | 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 @@ -74,7 +74,7 @@ {-# INLINE generic #-} -- | Convert from the data type to its representation (or back) -generic1 :: Generic1 f => Iso' (f a) (Rep1 f a) +generic1 :: Generic1 f => Iso (f a) (f b) (Rep1 f a) (Rep1 f b) generic1 = iso from1 to1 {-# INLINE generic1 #-} diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -20,7 +20,13 @@ -- Stability : experimental -- Portability : TemplateHaskell -- --- Lenses, Prisms, and Traversals for working with Template Haskell +-- Lenses, Prisms, and Traversals for working with Template Haskell. +-- +-- Beware that the API offered in this module is subject to change, as it +-- mirrors the API exposed by the @template-haskell@ package, which +-- frequently changes between different releases of GHC. An effort is made +-- to identify the functions in this module which have different type +-- signatures when compiled with different versions of @template-haskell@. ---------------------------------------------------------------------------- module Language.Haskell.TH.Lens ( @@ -62,6 +68,9 @@ , fieldPatPattern #if MIN_VERSION_template_haskell(2,9,0) -- ** TySynEqn Lenses +# if MIN_VERSION_template_haskell(2,15,0) + , tySynEqnLHS +# endif , tySynEqnPatterns , tySynEqnResult #endif @@ -131,6 +140,9 @@ , _PatSynD , _PatSynSigD #endif +#if MIN_VERSION_template_haskell(2,15,0) + , _ImplicitParamBindD +#endif #if MIN_VERSION_template_haskell(2,12,0) -- ** PatSynDir Prisms , _Unidir @@ -280,6 +292,10 @@ #if MIN_VERSION_template_haskell(2,13,0) , _LabelE #endif +#if MIN_VERSION_template_haskell(2,15,0) + , _MDoE + , _ImplicitParamVarE +#endif -- ** Body Prisms , _GuardedB , _NormalB @@ -291,6 +307,9 @@ , _LetS , _NoBindS , _ParS +#if MIN_VERSION_template_haskell(2,15,0) + , _RecS +#endif -- ** Range Prisms , _FromR , _FromThenR @@ -362,6 +381,10 @@ , _ParensT , _WildCardT #endif +#if MIN_VERSION_template_haskell(2,15,0) + , _AppKindT + , _ImplicitParamT +#endif -- ** TyVarBndr Prisms , _PlainTV , _KindedTV @@ -416,6 +439,10 @@ #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 import Prelude -- | Has a 'Name' @@ -492,9 +519,18 @@ #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 +#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 @@ -517,21 +553,31 @@ | otherwise = f n instance HasTypeVars Type where - typeVarsEx s f (VarT n) = VarT <$> typeVarsEx s f n - typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r - typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t - typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty + typeVarsEx s f (VarT n) = VarT <$> typeVarsEx s f n + typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r +#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 + typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty where s' = s `Set.union` setOf typeVars bs #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 - typeVarsEx s f (UInfixT t1 n t2) = UInfixT <$> typeVarsEx s f t1 - <*> pure n - <*> typeVarsEx s f t2 - typeVarsEx s f (ParensT t) = ParensT <$> typeVarsEx s f t + typeVarsEx s f (InfixT t1 n t2) = InfixT <$> typeVarsEx s f t1 + <*> pure n + <*> typeVarsEx s f t2 + typeVarsEx s f (UInfixT t1 n t2) = UInfixT <$> typeVarsEx s f t1 + <*> pure n + <*> typeVarsEx s f t2 + typeVarsEx s f (ParensT t) = ParensT <$> typeVarsEx s f t #endif - typeVarsEx _ _ t = pure t +#if MIN_VERSION_template_haskell(2,15,0) + typeVarsEx s f (AppKindT t k) = AppKindT <$> typeVarsEx s f t + <*> typeVarsEx s f k + typeVarsEx s f (ImplicitParamT n t) = ImplicitParamT n <$> typeVarsEx s f t +#endif + typeVarsEx _ _ t = pure t #if !MIN_VERSION_template_haskell(2,10,0) instance HasTypeVars Pred where @@ -575,16 +621,24 @@ substType :: Map Name Type -> t -> t instance SubstType Type where - substType m t@(VarT n) = fromMaybe t (m^.at n) - substType m (ForallT bs ctx ty) = ForallT bs (substType m' ctx) (substType m' ty) + substType m t@(VarT n) = fromMaybe t (m^.at n) + substType m (ForallT bs ctx ty) = ForallT bs (substType m' ctx) (substType m' ty) where m' = foldrOf typeVars Map.delete m bs - substType m (SigT t k) = SigT (substType m t) k - substType m (AppT l r) = AppT (substType m l) (substType m r) +#if MIN_VERSION_template_haskell(2,8,0) + substType m (SigT t k) = SigT (substType m t) (substType m k) +#else + substType m (SigT t k) = SigT (substType m t) k +#endif + substType m (AppT l r) = AppT (substType m l) (substType m r) #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 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) #endif +#if MIN_VERSION_template_haskell(2,15,0) + substType m (AppKindT t k) = AppKindT (substType m t) (substType m k) + substType m (ImplicitParamT n t) = ImplicitParamT n (substType m t) +#endif substType _ t = t instance SubstType t => SubstType [t] where @@ -597,6 +651,11 @@ #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 @@ -614,6 +673,11 @@ 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 @@ -622,6 +686,11 @@ 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 @@ -785,6 +854,12 @@ 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 @@ -839,6 +914,12 @@ 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 @@ -861,6 +942,11 @@ 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 @@ -929,6 +1015,11 @@ 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 @@ -1010,23 +1101,28 @@ remitter (PragmaD x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,9,0) -_TySynInstD :: Prism' Dec (Name, TySynEqn) +-- | +-- @ +-- _TySynInstD :: 'Prism'' 'Dec' 'TySynEqn' -- template-haskell-2.15+ +-- _TySynInstD :: 'Prism'' 'Dec' ('Name', 'TySynEqn') -- template-haskell-2.9 through 2.14 +-- _TySynInstD :: 'Prism'' 'Dec' ('Name', ['Type'], 'Type') -- Earlier versions +-- @ +#if MIN_VERSION_template_haskell(2,15,0) +_TySynInstD :: Prism' Dec TySynEqn _TySynInstD = prism' reviewer remitter where - reviewer (x, y) = TySynInstD x y - remitter (TySynInstD x y) = Just (x, y) + reviewer = TySynInstD + remitter (TySynInstD x) = Just x remitter _ = Nothing - -_RoleAnnotD :: Prism' Dec (Name, [Role]) -_RoleAnnotD +#elif MIN_VERSION_template_haskell(2,9,0) +_TySynInstD :: Prism' Dec (Name, TySynEqn) +_TySynInstD = prism' reviewer remitter where - reviewer (x, y) = RoleAnnotD x y - remitter (RoleAnnotD x y) = Just (x, y) + reviewer (x, y) = TySynInstD x y + remitter (TySynInstD x y) = Just (x, y) remitter _ = Nothing - #else _TySynInstD :: Prism' Dec (Name, [Type], Type) _TySynInstD @@ -1037,6 +1133,21 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,9,0) +_RoleAnnotD :: Prism' Dec (Name, [Role]) +_RoleAnnotD + = prism' reviewer remitter + where + reviewer (x, y) = RoleAnnotD x y + remitter (RoleAnnotD x y) = Just (x, y) + remitter _ = Nothing +#endif + +-- | +-- @ +-- _StandaloneDerivD :: 'Prism'' 'Dec' ('Maybe' 'DerivStrategy', 'Cxt', 'Type') -- template-haskell-2.12+ +-- _StandaloneDerivD :: 'Prism'' 'Dec' ('Cxt', 'Type') -- Earlier versions +-- @ #if MIN_VERSION_template_haskell(2,12,0) _StandaloneDerivD :: Prism' Dec (Maybe DerivStrategy, Cxt, Type) _StandaloneDerivD @@ -1065,47 +1176,28 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,11,0) -_ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn]) -_ClosedTypeFamilyD - = prism' reviewer remitter - where - reviewer (x, y) = ClosedTypeFamilyD x y - remitter (ClosedTypeFamilyD x y) = Just (x, y) - remitter _ = Nothing -#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 - -#if MIN_VERSION_template_haskell(2,11,0) # if MIN_VERSION_template_haskell(2,12,0) type DataPrism' tys cons = Prism' Dec (Cxt, Name, tys, Maybe Kind, cons, [DerivClause]) -# else +# elif MIN_VERSION_template_haskell(2,11,0) type DataPrism' tys cons = Prism' Dec (Cxt, Name, tys, Maybe Kind, cons, Cxt) # endif -_DataD :: DataPrism' [TyVarBndr] [Con] -_DataD - = prism' reviewer remitter - where - reviewer (x, y, z, w, u, v) = DataD x y z w u v - remitter (DataD x y z w u v) = Just (x, y, z, w, u, v) - remitter _ = Nothing - -_NewtypeD :: DataPrism' [TyVarBndr] Con -_NewtypeD +-- | +-- @ +-- _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 +-- @ +#if MIN_VERSION_template_haskell(2,15,0) +_DataInstD :: Prism' Dec (Cxt, Maybe [TyVarBndr], Type, Maybe Kind, [Con], [DerivClause]) +_DataInstD = 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) + 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) _DataInstD :: DataPrism' [Type] [Con] _DataInstD = prism' reviewer remitter @@ -1113,7 +1205,32 @@ 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 +-- @ +#if MIN_VERSION_template_haskell(2,15,0) +_NewtypeInstD :: Prism' Dec (Cxt, Maybe [TyVarBndr], 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) _NewtypeInstD :: DataPrism' [Type] Con _NewtypeInstD = prism' reviewer remitter @@ -1121,21 +1238,47 @@ 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 -_DataFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind) -_DataFamilyD +#if MIN_VERSION_template_haskell(2,11,0) +_ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn]) +_ClosedTypeFamilyD = prism' reviewer remitter where - reviewer (x, y, z) = DataFamilyD x y z - remitter (DataFamilyD x y z) = Just (x, y, z) + 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 -_OpenTypeFamilyD :: Prism' Dec TypeFamilyHead -_OpenTypeFamilyD +-- | +-- @ +-- _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 +-- @ +#if MIN_VERSION_template_haskell(2,11,0) +_DataD :: DataPrism' [TyVarBndr] [Con] +_DataD = prism' reviewer remitter where - reviewer = OpenTypeFamilyD - remitter (OpenTypeFamilyD x) = Just x + 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]) @@ -1145,7 +1288,23 @@ 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 +-- @ +#if MIN_VERSION_template_haskell(2,11,0) +_NewtypeD :: DataPrism' [TyVarBndr] 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 @@ -1153,23 +1312,25 @@ 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 -_DataInstD :: Prism' Dec (Cxt, Name, [Type], [Con], [Name]) -_DataInstD +#if MIN_VERSION_template_haskell(2,11,0) +_DataFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind) +_DataFamilyD = 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) + reviewer (x, y, z) = DataFamilyD x y z + remitter (DataFamilyD x y z) = Just (x, y, z) remitter _ = Nothing -_NewtypeInstD :: Prism' Dec (Cxt, Name, [Type], Con, [Name]) -_NewtypeInstD +_OpenTypeFamilyD :: Prism' Dec TypeFamilyHead +_OpenTypeFamilyD = 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) + reviewer = OpenTypeFamilyD + remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing - +#else _FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndr], Maybe Kind) _FamilyD = prism' reviewer remitter @@ -1197,6 +1358,16 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,15,0) +_ImplicitParamBindD :: Prism' Dec (String, Exp) +_ImplicitParamBindD + = prism' reviewer remitter + where + reviewer (x, y) = ImplicitParamBindD x y + remitter (ImplicitParamBindD x y) = Just (x, y) + remitter _ = Nothing +#endif + #if MIN_VERSION_template_haskell(2,12,0) _Unidir :: Prism' PatSynDir () _Unidir @@ -1247,6 +1418,11 @@ 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) @@ -1262,6 +1438,11 @@ 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) @@ -1277,6 +1458,11 @@ 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) @@ -1497,6 +1683,11 @@ 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 @@ -1505,14 +1696,6 @@ reviewer (x, y, z, w) = InlineP x y z w remitter (InlineP x y z w) = Just (x, y, z, w) remitter _ = Nothing - -_SpecialiseP :: Prism' Pragma (Name, Type, Maybe Inline, Phases) -_SpecialiseP - = prism' reviewer remitter - where - reviewer (x, y, z, w) = SpecialiseP x y z w - remitter (SpecialiseP x y z w) = Just (x, y, z, w) - remitter _ = Nothing #else _InlineP :: Prism' Pragma (Name, InlineSpec) _InlineP @@ -1521,7 +1704,22 @@ 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 + where + 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 @@ -1529,9 +1727,9 @@ 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 -#endif #if MIN_VERSION_template_haskell(2,8,0) _SpecialiseInstP :: Prism' Pragma Type @@ -1542,6 +1740,20 @@ remitter (SpecialiseInstP x) = Just x remitter _ = Nothing +-- | +-- @ +-- _RuleP :: 'Prism'' 'Pragma' ('String', 'Maybe' ['TyVarBndr'], ['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' reviewer remitter + where + reviewer (x, y, z, w, u, v) = RuleP x y z w u v + remitter (RuleP x y z w u v) = Just (x, y, z, w, u, v) + remitter _ = Nothing +#else _RuleP :: Prism' Pragma (String, [RuleBndr], Exp, Exp, Phases) _RuleP = prism' reviewer remitter @@ -1549,6 +1761,7 @@ reviewer (x, y, z, w, u) = RuleP x y z w u remitter (RuleP x y z w u) = Just (x, y, z, w, u) remitter _ = Nothing +#endif #if MIN_VERSION_template_haskell(2,9,0) _AnnP :: Prism' Pragma (AnnTarget, Exp) @@ -1712,9 +1925,26 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) +#if MIN_VERSION_template_haskell(2,15,0) +tySynEqnLHS :: Lens' TySynEqn Type +tySynEqnLHS = lens g s where + g (TySynEqn _ lhs _) = lhs + s (TySynEqn mtvbs _ rhs) lhs = TySynEqn mtvbs lhs rhs + tySynEqnPatterns :: Lens' TySynEqn [Type] tySynEqnPatterns = lens g s where + g (TySynEqn _ lhs _) = pats + where (_n, pats) = unfoldType lhs + s (TySynEqn mtvbs lhs rhs) pats = TySynEqn mtvbs (F.foldl' AppT n pats) rhs + where (n, _pats) = unfoldType lhs + +tySynEqnResult :: Lens' TySynEqn Type +tySynEqnResult = lens g s where + g (TySynEqn _ _ rhs) = rhs + s (TySynEqn mtvbs lhs _) = TySynEqn mtvbs lhs +#elif MIN_VERSION_template_haskell(2,9,0) +tySynEqnPatterns :: Lens' TySynEqn [Type] +tySynEqnPatterns = lens g s where g (TySynEqn xs _) = xs s (TySynEqn _ y) xs = TySynEqn xs y @@ -1978,6 +2208,24 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,15,0) +_MDoE :: Prism' Exp [Stmt] +_MDoE + = prism' reviewer remitter + where + reviewer = MDoE + remitter (MDoE x) = Just x + remitter _ = Nothing + +_ImplicitParamVarE :: Prism' Exp String +_ImplicitParamVarE + = prism' reviewer remitter + where + reviewer = ImplicitParamVarE + remitter (ImplicitParamVarE x) = Just x + remitter _ = Nothing +#endif + _GuardedB :: Prism' Body [(Guard, Exp)] _GuardedB = prism' reviewer remitter @@ -2042,6 +2290,16 @@ remitter (ParS x) = Just x remitter _ = Nothing +#if MIN_VERSION_template_haskell(2,15,0) +_RecS :: Prism' Stmt [Stmt] +_RecS + = prism' reviewer remitter + where + reviewer = RecS + remitter (RecS x) = Just x + remitter _ = Nothing +#endif + _FromR :: Prism' Range Exp _FromR = prism' reviewer remitter @@ -2487,6 +2745,24 @@ where reviewer () = WildCardT remitter WildCardT = Just () + remitter _ = Nothing +#endif + +#if MIN_VERSION_template_haskell(2,15,0) +_AppKindT :: Prism' Type (Type, Kind) +_AppKindT + = prism' reviewer remitter + where + reviewer (x, y) = AppKindT x y + remitter (AppKindT x y) = Just (x, y) + remitter _ = Nothing + +_ImplicitParamT :: Prism' Type (String, Type) +_ImplicitParamT + = prism' reviewer remitter + where + reviewer (x, y) = ImplicitParamT x y + remitter (ImplicitParamT x y) = Just (x, y) remitter _ = Nothing #endif 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 @@ -108,10 +108,18 @@ {-# INLINE (<=) #-} +-- | Add a path onto the end of the target of a 'Lens' and return the original +-- value. +-- +-- When you do not need the original value, ('~') is more flexible. (<<~) :: Optical' (->) q ((,)FilePath) s FilePath -> FilePath -> q s (FilePath, s) l <<~ b = l $ \a -> (a, a b) {-# INLINE (<<~) #-} +-- | Add a path onto the end of a target of a 'Lens' into your monad's state +-- and return the old value. +-- +-- When you do not need the result of the operation, ('=') is more flexible. (<<=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> FilePath -> m FilePath l <<= b = l %%= \a -> (a, a b) {-# INLINE (<<=) #-} @@ -179,6 +187,13 @@ l <<<.>~ b = l $ \a -> (a, a <.> b) {-# INLINE (<<<.>~) #-} +-- | Add an extension onto the end of the target of a 'Lens' into your monad's +-- state and return the old value. +-- +-- >>> runState (_1 <<<.>= "txt") ("hello","world") +-- ("hello",("hello.txt","world")) +-- +-- When you do not need the old value, ('<.>=') is more flexible. (<<<.>=) :: MonadState s m => LensLike' ((,)FilePath) s FilePath -> String -> m FilePath l <<<.>= b = l %%= \a -> (a, a <.> b) {-# INLINE (<<<.>=) #-} diff --git a/tests/templates.hs b/tests/templates.hs --- a/tests/templates.hs +++ b/tests/templates.hs @@ -441,6 +441,16 @@ checkAbbreviatedNamer :: Lens' CheckAbbreviatedNamer Int checkAbbreviatedNamer = fieldAbbreviatedNamer +-- Ensure that `makeClassyPrisms` doesn't generate a redundant catch-all case (#866) +data T866 = MkT866 +$(makeClassyPrisms ''T866) + +-- Ensure that `makeClassyPrisms` doesn't generate duplicate prism names for +-- data types that share a name with one of its constructors (#865) +data T865 = T865 | T865a | T865b T866 +$(makeClassyPrisms ''T865) +instance AsT866 T865 where + _T866 = __T865 . _T866 main :: IO () main = putStrLn "test/templates.hs: ok"