lens 4.17.1 → 4.18
raw patch · 39 files changed
+1599/−392 lines, 39 filesdep +type-equalitydep ~bytestringdep ~template-haskelldep ~th-abstraction
Dependencies added: type-equality
Dependency ranges changed: bytestring, template-haskell, th-abstraction
Files
- .hlint.yaml +25/−0
- .travis.yml +127/−103
- CHANGELOG.markdown +44/−5
- HLint.hs +0/−40
- examples/.hlint.yaml +11/−0
- examples/lens-examples.cabal +2/−1
- images/Hierarchy.png binary
- images/overview.png binary
- lens-properties/.hlint.yaml +11/−0
- lens-properties/lens-properties.cabal +2/−1
- lens.cabal +15/−10
- src/Control/Exception/Lens.hs +310/−36
- src/Control/Lens/Each.hs +8/−0
- src/Control/Lens/Equality.hs +91/−2
- src/Control/Lens/Fold.hs +52/−12
- src/Control/Lens/Internal/Bazaar.hs +60/−4
- src/Control/Lens/Internal/ByteString.hs +2/−4
- src/Control/Lens/Internal/Context.hs +3/−0
- src/Control/Lens/Internal/Exception.hs +5/−1
- src/Control/Lens/Internal/PrismTH.hs +78/−16
- src/Control/Lens/Internal/TH.hs +28/−12
- src/Control/Lens/Internal/Typeable.hs +24/−0
- src/Control/Lens/Iso.hs +111/−11
- src/Control/Lens/Lens.hs +59/−1
- src/Control/Lens/Prism.hs +5/−0
- src/Control/Lens/TH.hs +16/−2
- src/Control/Lens/Traversal.hs +14/−8
- src/Control/Lens/Type.hs +1/−1
- src/Control/Lens/Unsound.hs +16/−5
- src/Control/Lens/Wrapped.hs +3/−3
- src/Control/Lens/Zoom.hs +17/−3
- src/Control/Monad/Error/Lens.hs +3/−1
- src/Data/Bits/Lens.hs +52/−0
- src/Data/Data/Lens.hs +12/−18
- src/Data/HashSet/Lens.hs +0/−1
- src/GHC/Generics/Lens.hs +1/−1
- src/Language/Haskell/TH/Lens.hs +366/−90
- src/System/FilePath/Lens.hs +15/−0
- tests/templates.hs +10/−0
+ .hlint.yaml view
@@ -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 </>~, <</>~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~"+- fixity: "infix 4 </>=, <</>=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**="+- fixity: "infixr 2 `zoom`, `magnify`, <~, <<~"+- fixity: "infixl 1 &, &~, <&>, ??"
.travis.yml view
@@ -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
CHANGELOG.markdown view
@@ -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]
− HLint.hs
@@ -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 %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=-infix 4 %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=--infixr 2 `zoom`, `magnify`-infixr 2 <~-infixr 2 <<~--infixl 1 &, &~, <&>, ??
+ examples/.hlint.yaml view
@@ -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 </>~, <</>~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~"+- fixity: "infix 4 </>=, <</>=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**="+- fixity: "infixr 2 `zoom`, `magnify`, <~, <<~"+- fixity: "infixl 1 &, &~, <&>, ??"
examples/lens-examples.cabal view
@@ -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
images/Hierarchy.png view
binary file changed (855621 → 209295 bytes)
images/overview.png view
binary file changed (316113 → 239100 bytes)
+ lens-properties/.hlint.yaml view
@@ -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 </>~, <</>~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~"+- fixity: "infix 4 </>=, <</>=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**="+- fixity: "infixr 2 `zoom`, `magnify`, <~, <<~"+- fixity: "infixl 1 &, &~, <&>, ??"
lens-properties/lens-properties.cabal view
@@ -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
lens.cabal view
@@ -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 @@ . <<http://i.imgur.com/ALlbPRa.png>> .- <Hierarchy.png (Local Copy)>+ <images/Hierarchy.png (Local Copy)> . 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
src/Control/Exception/Lens.hs view
@@ -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 ("<interactive>" `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
src/Control/Lens/Each.hs view
@@ -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
src/Control/Lens/Equality.hs view
@@ -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 #-}
src/Control/Lens/Fold.hs view
@@ -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))
src/Control/Lens/Internal/Bazaar.hs view
@@ -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")
src/Control/Lens/Internal/ByteString.hs view
@@ -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)
src/Control/Lens/Internal/Context.hs view
@@ -67,6 +67,9 @@ -- "Parameterized Notions of Computation" <http://bentnib.org/paramnotions-jfp.pdf> -- 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
src/Control/Lens/Internal/Exception.hs view
@@ -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
src/Control/Lens/Internal/PrismTH.hs view
@@ -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
src/Control/Lens/Internal/TH.hs view
@@ -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
+ src/Control/Lens/Internal/Typeable.hs view
@@ -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
src/Control/Lens/Iso.hs view
@@ -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 <ekmett@gmail.com> -- 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'.
src/Control/Lens/Lens.hs view
@@ -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. --
src/Control/Lens/Prism.hs view
@@ -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
src/Control/Lens/TH.hs view
@@ -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
src/Control/Lens/Traversal.hs view
@@ -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)
src/Control/Lens/Type.hs view
@@ -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'. --
src/Control/Lens/Unsound.hs view
@@ -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
src/Control/Lens/Wrapped.hs view
@@ -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 #-}
src/Control/Lens/Zoom.hs view
@@ -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
src/Control/Monad/Error/Lens.hs view
@@ -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" #-}
src/Data/Bits/Lens.hs view
@@ -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 (<<.|.=) #-}
src/Data/Data/Lens.hs view
@@ -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
src/Data/HashSet/Lens.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- |
src/GHC/Generics/Lens.hs view
@@ -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 #-}
src/Language/Haskell/TH/Lens.hs view
@@ -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
src/System/FilePath/Lens.hs view
@@ -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 (<<<.>=) #-}
tests/templates.hs view
@@ -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"