lens 4.19.2 → 5
raw patch · 95 files changed
+1344/−2401 lines, 95 filesdep +assocdep +indexed-traversabledep +indexed-traversable-instancesdep −directorydep −doctestdep −type-equalitydep ~arraydep ~basedep ~bytestringsetup-changed
Dependencies added: assoc, indexed-traversable, indexed-traversable-instances, strict, these
Dependencies removed: directory, doctest, type-equality
Dependency ranges changed: array, base, bytestring, call-stack, comonad, containers, filepath, free, generic-deriving, mtl, nats, parallel, profunctors, semigroups, template-haskell, text, th-abstraction, transformers, unordered-containers, vector
Files
- .hlint.yaml +7/−12
- .travis.yml +0/−190
- CHANGELOG.markdown +93/−0
- README.markdown +18/−7
- Setup.lhs +1/−29
- Warning.hs +0/−5
- benchmarks/traversals.hs +0/−21
- examples/.hlint.yaml +3/−10
- examples/Aeson.hs +6/−2
- examples/lens-examples.cabal +2/−4
- include/lens-common.h +1/−1
- lens-properties/.hlint.yaml +3/−10
- lens-properties/lens-properties.cabal +4/−5
- lens.cabal +60/−104
- src/Control/Exception/Lens.hs +3/−12
- src/Control/Lens.hs +0/−4
- src/Control/Lens/At.hs +93/−49
- src/Control/Lens/Combinators.hs +7/−7
- src/Control/Lens/Cons.hs +8/−9
- src/Control/Lens/Each.hs +44/−8
- src/Control/Lens/Empty.hs +24/−13
- src/Control/Lens/Equality.hs +2/−14
- src/Control/Lens/Fold.hs +3/−9
- src/Control/Lens/Getter.hs +2/−5
- src/Control/Lens/Indexed.hs +53/−808
- src/Control/Lens/Internal.hs +0/−5
- src/Control/Lens/Internal/Bazaar.hs +0/−6
- src/Control/Lens/Internal/ByteString.hs +10/−74
- src/Control/Lens/Internal/Coerce.hs +6/−27
- src/Control/Lens/Internal/Context.hs +1/−7
- src/Control/Lens/Internal/Deque.hs +5/−2
- src/Control/Lens/Internal/Exception.hs +2/−30
- src/Control/Lens/Internal/FieldTH.hs +19/−45
- src/Control/Lens/Internal/Fold.hs +0/−60
- src/Control/Lens/Internal/Indexed.hs +5/−11
- src/Control/Lens/Internal/Iso.hs +19/−18
- src/Control/Lens/Internal/Level.hs +24/−0
- src/Control/Lens/Internal/List.hs +0/−4
- src/Control/Lens/Internal/Magma.hs +24/−6
- src/Control/Lens/Internal/Prelude.hs +4/−0
- src/Control/Lens/Internal/Prism.hs +5/−10
- src/Control/Lens/Internal/PrismTH.hs +29/−38
- src/Control/Lens/Internal/Profunctor.hs +17/−0
- src/Control/Lens/Internal/Setter.hs +0/−2
- src/Control/Lens/Internal/TH.hs +78/−37
- src/Control/Lens/Internal/Typeable.hs +0/−24
- src/Control/Lens/Internal/Zoom.hs +1/−1
- src/Control/Lens/Iso.hs +41/−147
- src/Control/Lens/Lens.hs +19/−22
- src/Control/Lens/Level.hs +1/−3
- src/Control/Lens/Operators.hs +7/−7
- src/Control/Lens/Plated.hs +44/−10
- src/Control/Lens/Prism.hs +4/−22
- src/Control/Lens/Profunctor.hs +135/−0
- src/Control/Lens/Reified.hs +3/−2
- src/Control/Lens/Review.hs +17/−4
- src/Control/Lens/Setter.hs +3/−8
- src/Control/Lens/TH.hs +8/−20
- src/Control/Lens/Traversal.hs +5/−11
- src/Control/Lens/Tuple.hs +9/−4
- src/Control/Lens/Type.hs +1/−6
- src/Control/Lens/Unsound.hs +9/−8
- src/Control/Lens/Wrapped.hs +26/−26
- src/Control/Lens/Zoom.hs +3/−9
- src/Control/Monad/Error/Lens.hs +0/−4
- src/Data/Array/Lens.hs +1/−1
- src/Data/Bits/Lens.hs +2/−1
- src/Data/ByteString/Lazy/Lens.hs +7/−4
- src/Data/ByteString/Lens.hs +3/−3
- src/Data/ByteString/Strict/Lens.hs +6/−4
- src/Data/Complex/Lens.hs +2/−0
- src/Data/Data/Lens.hs +3/−14
- src/Data/HashSet/Lens.hs +2/−1
- src/Data/IntSet/Lens.hs +4/−2
- src/Data/List/Lens.hs +3/−2
- src/Data/Map/Lens.hs +1/−0
- src/Data/Sequence/Lens.hs +16/−12
- src/Data/Set/Lens.hs +4/−6
- src/Data/Text/Lazy/Lens.hs +7/−4
- src/Data/Text/Lens.hs +4/−3
- src/Data/Text/Strict/Lens.hs +7/−5
- src/Data/Tree/Lens.hs +4/−0
- src/Data/Vector/Generic/Lens.hs +16/−14
- src/Data/Vector/Lens.hs +14/−9
- src/GHC/Generics/Lens.hs +3/−4
- src/Language/Haskell/TH/Lens.hs +148/−172
- src/Numeric/Lens.hs +1/−0
- src/System/FilePath/Lens.hs +3/−0
- tests/T917.hs +45/−0
- tests/doctests.hs +5/−11
- tests/hunit.hs +11/−15
- tests/properties.hs +0/−13
- tests/templates.hs +1/−5
- travis/cabal-apt-install +0/−22
- travis/config +0/−16
.hlint.yaml view
@@ -1,4 +1,4 @@-- arguments: [--cpp-define=HLINT, --cpp-ansi, --cpp-include=include]+- arguments: [--cpp-ansi, --cpp-include=include] - ignore: {name: Reduce duplication} - ignore: {name: Redundant lambda}@@ -10,17 +10,12 @@ - ignore: {name: Use fewer imports} - ignore: {name: "Use :"} - ignore: {name: Use typeRep, within: [Control.Lens.Internal.Typeable, Control.Lens.Internal.Exception]}-- ignore: {name: Eta reduce, within: [Control.Lens.Zoom]} # Breaks code+- ignore: {name: Eta reduce, within: [Control.Lens.Zoom, Control.Lens.Equality, Control.Lens.Traversal]} # Breaks code+- ignore: {name: Use id, within: [Control.Lens.Equality]} - ignore: {name: Use camelCase, within: [Control.Lens.Internal.TH]} - ignore: {name: Use list comprehension, within: [Control.Lens.Internal.FieldTH]}-- ignore: {name: Use fmap, within: [Control.Exception.Lens]} # Needed to support pre-AMP GHCs+- ignore: {name: Use fmap, within: [Control.Exception.Lens, Control.Lens.Internal.Zoom, Control.Lens.Zoom, Control.Lens.Indexed, Control.Lens.Fold, Control.Monad.Error.Lens,Control.Lens.Setter]} # Needed to support pre-AMP GHC-7.8+- ignore: {name: Use uncurry} -- fixity: "infixl 9 :>"-- fixity: "infixr 9 <.>, <., .>, ..."-- fixity: "infixr 9 #."-- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#"-- fixity: "infixr 8 ^!, ^@!"-- fixity: "infixr 4 </>~, <</>~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~"-- fixity: "infix 4 </>=, <</>=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**="-- fixity: "infixr 2 `zoom`, `magnify`, <~, <<~"-- fixity: "infixl 1 &, &~, <&>, ??"+- fixity: "infixr 9 ..."+- fixity: "infixl 1 &~"
− .travis.yml
@@ -1,190 +0,0 @@-# This Travis job script has been generated by a script via-#-# haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project'-#-# To regenerate the script (for example after adjusting tested-with) run-#-# haskell-ci regenerate-#-# For more information, see https://github.com/haskell-CI/haskell-ci-#-# version: 0.10-#-version: ~> 1.0-language: c-os: linux-dist: xenial-git:- # whether to recursively clone submodules- submodules: false-notifications:- irc:- channels:- - irc.freenode.org#haskell-lens- skip_join: true- template:- - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"-cache:- directories:- - $HOME/.cabal/packages- - $HOME/.cabal/store- - $HOME/.hlint-before_cache:- - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log- # remove files that are regenerated by 'cabal update'- - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*- - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json- - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache- - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar- - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx- - rm -rfv $CABALHOME/packages/head.hackage-jobs:- include:- - compiler: ghc-8.10.1- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-8.8.3- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-8.6.5- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-8.4.4- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-8.2.2- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-8.0.2- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-7.10.3- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-7.8.4- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-7.6.3- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.2","freeglut3-dev"]}}- os: linux- - compiler: ghc-7.4.2- addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.2","freeglut3-dev"]}}- os: linux-before_install:- - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')- - WITHCOMPILER="-w $HC"- - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')- - HCPKG="$HC-pkg"- - unset CC- - CABAL=/opt/ghc/bin/cabal- - CABALHOME=$HOME/.cabal- - export PATH="$CABALHOME/bin:$PATH"- - TOP=$(pwd)- - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"- - echo $HCNUMVER- - CABAL="$CABAL -vnormal+nowrap"- - set -o pipefail- - TEST=--enable-tests- - BENCH=--enable-benchmarks- - HEADHACKAGE=false- - rm -f $CABALHOME/config- - |- echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config- echo "remote-build-reporting: anonymous" >> $CABALHOME/config- echo "write-ghc-environment-files: always" >> $CABALHOME/config- echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config- echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config- echo "world-file: $CABALHOME/world" >> $CABALHOME/config- echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config- echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config- echo "installdir: $CABALHOME/bin" >> $CABALHOME/config- echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config- echo "store-dir: $CABALHOME/store" >> $CABALHOME/config- echo "install-dirs user" >> $CABALHOME/config- echo " prefix: $CABALHOME" >> $CABALHOME/config- echo "repository hackage.haskell.org" >> $CABALHOME/config- echo " url: http://hackage.haskell.org/" >> $CABALHOME/config-install:- - ${CABAL} --version- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"- - |- echo "program-default-options" >> $CABALHOME/config- echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config- - cat $CABALHOME/config- - rm -fv cabal.project cabal.project.local cabal.project.freeze- - travis_retry ${CABAL} v2-update -v- - if [ $HCNUMVER -ge 81000 ] ; then HLINTVER=$(cd /tmp && (${CABAL} v2-install -v $WITHCOMPILER --dry-run hlint --constraint='hlint ==2.2.*' | perl -ne 'if (/\bhlint-(\d+(\.\d+)*)\b/) { print "$1"; last; }')); echo "HLint version $HLINTVER" ; fi- - "if [ $HCNUMVER -ge 81000 ] ; then if [ ! -e $HOME/.hlint/hlint-$HLINTVER/hlint ]; then echo \"Downloading HLint version $HLINTVER\"; mkdir -p $HOME/.hlint; curl --write-out 'Status Code: %{http_code} Redirects: %{num_redirects} Total time: %{time_total} Total Dsize: %{size_download}\\n' --silent --location --output $HOME/.hlint/hlint-$HLINTVER.tar.gz \"https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz\"; tar -xzv -f $HOME/.hlint/hlint-$HLINTVER.tar.gz -C $HOME/.hlint; fi ; fi"- - if [ $HCNUMVER -ge 81000 ] ; then mkdir -p $CABALHOME/bin && ln -sf "$HOME/.hlint/hlint-$HLINTVER/hlint" $CABALHOME/bin/hlint ; fi- - if [ $HCNUMVER -ge 81000 ] ; then hlint --version ; fi- # Generate cabal.project- - rm -rf cabal.project cabal.project.local cabal.project.freeze- - touch cabal.project- - |- echo "packages: ." >> cabal.project- echo "packages: ./examples" >> cabal.project- echo "packages: ./lens-properties" >> cabal.project- - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens' >> cabal.project ; fi- - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"- - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-examples' >> cabal.project ; fi- - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"- - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-properties' >> cabal.project ; fi- - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"- - |- - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lens|lens-examples|lens-properties)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"- - cat cabal.project || true- - cat cabal.project.local || true- - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi- - if [ -f "./examples/configure.ac" ]; then (cd "./examples" && autoreconf -i); fi- - if [ -f "./lens-properties/configure.ac" ]; then (cd "./lens-properties" && autoreconf -i); fi- - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}- - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"- - rm cabal.project.freeze- - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all-script:- - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)- # Packaging...- - ${CABAL} v2-sdist all- # Unpacking...- - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/- - cd ${DISTDIR} || false- - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;- - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;- - PKGDIR_lens="$(find . -maxdepth 1 -type d -regex '.*/lens-[0-9.]*')"- - PKGDIR_lens_examples="$(find . -maxdepth 1 -type d -regex '.*/lens-examples-[0-9.]*')"- - PKGDIR_lens_properties="$(find . -maxdepth 1 -type d -regex '.*/lens-properties-[0-9.]*')"- # Generate cabal.project- - rm -rf cabal.project cabal.project.local cabal.project.freeze- - touch cabal.project- - |- echo "packages: ${PKGDIR_lens}" >> cabal.project- echo "packages: ${PKGDIR_lens_examples}" >> cabal.project- echo "packages: ${PKGDIR_lens_properties}" >> cabal.project- - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens' >> cabal.project ; fi- - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"- - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-examples' >> cabal.project ; fi- - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"- - if [ $HCNUMVER -ge 80200 ] ; then echo 'package lens-properties' >> cabal.project ; fi- - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"- - |- - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(lens|lens-examples|lens-properties)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"- - cat cabal.project || true- - cat cabal.project.local || true- # Building with tests and benchmarks...- # build & run tests, build benchmarks- - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all- # Testing...- - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all- # HLint..- - if [ $HCNUMVER -ge 81000 ] ; then (cd ${PKGDIR_lens} && hlint src) ; fi- - if [ $HCNUMVER -ge 81000 ] ; then (cd ${PKGDIR_lens_examples} && hlint .) ; fi- - if [ $HCNUMVER -ge 81000 ] ; then (cd ${PKGDIR_lens_properties} && hlint src) ; fi- # cabal check...- - (cd ${PKGDIR_lens} && ${CABAL} -vnormal check)- - (cd ${PKGDIR_lens_examples} && ${CABAL} -vnormal check)- - (cd ${PKGDIR_lens_properties} && ${CABAL} -vnormal check)- # haddock...- - if [ $HCNUMVER -lt 70600 ] || [ $HCNUMVER -ge 70800 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi--# REGENDATA ("0.10",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"])-# EOF
CHANGELOG.markdown view
@@ -1,3 +1,96 @@+5 [2021.02.17]+--------------+* Support building with GHC 9.0.+* Remove the `Swapped` type class in favor of `Swap` from the `assoc` package.+* Remove the `Strict` type class in favor of `Strict` from the `strict` package.++ The `swapped`, `strict` and `lazy` isomorphisms are now defined using "new" type classes.++ Users which define own instances of old type classes are advised to+ define instances of the new ones.++ ```haskell+ import qualified Data.Bifunctor.Swap as Swap+ import qualified Control.Lens as Lens++ instance Swap.Swap MyType where+ swap = ...++ #if !MIN_VERSION_lens(4,20,0)+ instance Lens.Swapped MyType where+ swapped = iso Swap.swap Swap.swap+ #endif+ ```+* The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type classes+ have been migrated to a new package,+ [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable).++ The `imapped`, `ifolded` and `itraversed` methods are now top-level functions.+ If you are not defining these methods in your instances,+ you don't need to change your definitions.++ Beware: the `optics-core` package (versions <0.4) defines similar classes,+ and will also migrate to use `indexed-traversable` classes. Therefore, you+ might get duplicate instance errors if your package defines both.++ If you define your own `FunctorWithIndex` etc. instances,+ we recommend that you depend directly on the `indexed-traversable` package.+ If you want to continue support `lens-4` users, you may write++ ```haskell+ -- from indexed-traversable+ import Data.Functor.WithIndex++ -- from lens+ import qualified Control.Lens as L++ -- your (indexed) container+ data MySeq a = ...++ -- indexed-traversable instance+ instance FunctorWithIndex Int MySeq where imap = ...+ instance FoldableWithIndex Int MySeq where ifoldMap = ...+ instance TraversableWithIndex Int MySeq where itraverse = ...++ -- lens <5 instance, note the !+ #if !MIN_VERSION_lens(5,0,0)+ instance L.FunctorWithIndex Int MySeq where imap = imap+ instance L.FoldableWithIndex Int MySeq where ifoldMap = ifoldMap+ instance L.TraversableWithIndex Int MySeq where itraverse = itraverse+ #endif+ ```++ In other words, always provide `indexed-traversable` instances.+ If your package depends on `lens` and allows `lens-4`,+ you should additionally provide instances for `lens-4` type classes+ that can reuse the `indexed-traversable` instances.++* Make the functions in `Control.Lens.TH` work more robustly with poly-kinded+ data types. This can cause a breaking change under certain situations:+ * TH-generated optics for poly-kinded data types are now much more likely to+ mention kind variables in their definitions, which will require enabling+ the `PolyKinds` extension at use sites in order to typecheck.+ * Because TH-generated optics now quantify more kind variables than they did+ previously, this can affect the order of visible type applications.+* Generalize the types of `generic` and `generic1` to allow type-changing+ updates. If you wish to use the old, more restricted types of these+ functions, use `simple . generic` or `simple . generic1` instead.+* Add `Control.Lens.Profunctor` with conversion functions to and from+ profunctor optic representation.+* Add `Control.Lens.Review.reviewing`, which is like `review` but with a more+ polymorphic type.+* Mark `Control.Lens.Equality` as Trustworthy.+* The build-type has been changed from `Custom` to `Simple`.+ To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests.+* Use `alterF` in `At (HashMap k)` instance implementation.+* Use `alterF` in `At` and `Contains` instances for `Set`, `IntSet`, and+ `HashSet`.+* Avoid re-inserting keys already present in `ix` for `Set`, `IntSet`,+ and `HashSet`. For `Set` and `HashSet`, this changes the semantics+ slightly; if the user-supplied key is `==` to one already present in+ the set, then the latter will not be replaced in the result.+* Consume `()` values lazily in `Control.Lens.At`.+ 4.19.2 [2020.04.15] ------------------- * Remove the test suite's dependency on `test-framework-th`.
README.markdown view
@@ -1,7 +1,7 @@ Lens: Lenses, Folds, and Traversals ================================== -[](https://hackage.haskell.org/package/lens) [](http://travis-ci.org/ekmett/lens) [](http://packdeps.haskellers.com/reverse/lens)+[](https://hackage.haskell.org/package/lens) [](https://github.com/ekmett/lens/actions?query=workflow%3AHaskell-CI) [](http://packdeps.haskellers.com/reverse/lens) This package provides families of [lenses](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Type.hs), [isomorphisms](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Iso.hs), [folds](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Fold.hs), [traversals](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Traversal.hs), [getters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Getter.hs) and [setters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Setter.hs). @@ -203,18 +203,29 @@ will automatically derive ```haskell-neither :: Iso (Neither a b) (Neither c d) (Either a b) (Either c d)-nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d)+_Neither :: Iso (Neither a b) (Neither c d) (Either a b) (Either c d) ``` such that ```haskell-from neither = nor-from nor = neither-neither.nor = id-nor.neither = id+_Neither.from _Neither = id+from _Neither._Neither = id ```++Alternatively, you can use `makeLenses` to automatically derive isomorphisms for your own newtypes. e.g..++```hs+makeLenses ''Neither+```++will automatically derive++```hs+nor :: Iso (Either a b) (Either c d) (Neither a b) (Neither c d)+```++which behaves identically to `_Neither` above. There is also a fully operational, but simple game of [Pong](https://github.com/ekmett/lens/blob/master/examples/Pong.hs) in the [examples/](https://github.com/ekmett/lens/blob/master/examples/) folder.
Setup.lhs view
@@ -1,34 +1,6 @@ \begin{code}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-} module Main (main) where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif--#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"--#else--#ifdef MIN_VERSION_Cabal--- If the macro is defined, we have new cabal-install,--- but for some reason we don't have cabal-doctest in package-db------ Probably we are running cabal sdist, when otherwise using new-build--- workflow-import Warning ()-#endif--import Distribution.Simple-+import Distribution.Simple (defaultMain) main :: IO () main = defaultMain--#endif- \end{code}
− Warning.hs
@@ -1,5 +0,0 @@-module Warning- {-# WARNING ["You are configuring this package without cabal-doctest installed.",- "The doctests test-suite will not work as a result.",- "To fix this, install cabal-doctest before configuring."] #-}- () where
benchmarks/traversals.hs view
@@ -20,27 +20,6 @@ import Criterion.Main import Criterion.Types -#if !(MIN_VERSION_bytestring(0,10,0))-import Control.DeepSeq (NFData(..))-import qualified Data.ByteString.Internal as BS-#endif--#if !(MIN_VERSION_containers(0,5,0))-import qualified Data.Foldable as F-#endif--#if !(MIN_VERSION_bytestring(0,10,0))-instance NFData BS.ByteString where- rnf (BS.PS _ _ _) = ()-#endif--#if !(MIN_VERSION_containers(0,5,0))--- Sadly, containers doesn't export the constructor for Seq on older versions,--- so we'll have to settle for this inefficient implementation of rnf.-instance NFData a => NFData (S.Seq a) where- rnf = rnf . F.toList-#endif- main :: IO () main = defaultMainWith config [
examples/.hlint.yaml view
@@ -1,11 +1,4 @@-- arguments: [--cpp-define=HLINT, --cpp-ansi]+- arguments: [--cpp-ansi] -- fixity: "infixl 9 :>"-- fixity: "infixr 9 <.>, <., .>, ..."-- fixity: "infixr 9 #."-- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#"-- fixity: "infixr 8 ^!, ^@!"-- fixity: "infixr 4 </>~, <</>~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~"-- fixity: "infix 4 </>=, <</>=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**="-- fixity: "infixr 2 `zoom`, `magnify`, <~, <<~"-- fixity: "infixl 1 &, &~, <&>, ??"+- fixity: "infixr 9 ..."+- fixity: "infixl 1 &~"
examples/Aeson.hs view
@@ -11,14 +11,18 @@ import Control.Lens import Data.Aeson-import Data.ByteString.Lazy+import Data.ByteString.Lazy (ByteString) +-- $setup+-- >>> import Control.Lens+ -- | -- >>> review aeson 5 -- "5" -- >>> [1,2,3]^.re aeson -- "[1,2,3]"--- >>> aeson.both +~ 2 $ (2,3)^.re aeson+-- >>> let intPair = simple :: Iso' (Int,Int) (Int, Int)+-- >>> aeson.intPair.both +~ 2 $ (2,3)^.re aeson -- "[4,5]" aeson, aeson' :: (FromJSON a, ToJSON a) => Prism' ByteString a aeson = prism' encode decode
examples/lens-examples.cabal view
@@ -16,9 +16,7 @@ Pong Example build-type: Simple-tested-with: GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4+tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2@@ -42,7 +40,7 @@ build-depends: aeson, base >= 4.5 && < 5,- bytestring >= 0.9.1.10 && < 0.11,+ bytestring >= 0.9.1.10 && < 0.12, data-default-class, ghc-prim, lens
include/lens-common.h view
@@ -32,7 +32,7 @@ #endif #ifndef MIN_VERSION_parallel-#define MIN_VERSION_parallel(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL > 700)+#define MIN_VERSION_parallel(x,y,z) defined(__GLASGOW_HASKELL__) #endif #ifndef MIN_VERSION_reflection
lens-properties/.hlint.yaml view
@@ -1,11 +1,4 @@-- arguments: [--cpp-define=HLINT, --cpp-ansi]+- arguments: [--cpp-ansi] - ignore: { name: Use camelCase }-- fixity: "infixl 9 :>"-- fixity: "infixr 9 <.>, <., .>, ..."-- fixity: "infixr 9 #."-- fixity: "infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?!, ^., ^@., ^#, .#"-- fixity: "infixr 8 ^!, ^@!"-- fixity: "infixr 4 </>~, <</>~, <.>~, <<.>~, <#~, #~, #%~, <#%~, #%%~, .|.~, .&.~, <.|.~, <.&.~, %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, %%@~, <%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~"-- fixity: "infix 4 </>=, <</>=, <.>=, <<.>=, <#=, #=, #%=, <#%=, #%%=, .|.=, .&.=, <.|.=, <.&.=, %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, %%@=, <%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**="-- fixity: "infixr 2 `zoom`, `magnify`, <~, <<~"-- fixity: "infixl 1 &, &~, <&>, ??"+- fixity: "infixr 9 ..."+- fixity: "infixl 1 &~"
lens-properties/lens-properties.cabal view
@@ -2,7 +2,7 @@ category: Data, Lenses version: 4.11.1 license: BSD3-cabal-version: >= 1.8+cabal-version: >= 1.10 license-file: LICENSE author: Edward Kmett and Oliver Charles maintainer: Edward Kmett <ekmett@gmail.com>@@ -13,9 +13,7 @@ synopsis: QuickCheck properties for lens description: QuickCheck properties for lens. build-type: Simple-tested-with: GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4+tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2@@ -35,7 +33,7 @@ library build-depends: base >= 4.5 && < 5,- lens >= 4 && < 5,+ lens >= 4 && < 6, QuickCheck >= 2.4 && < 2.15, transformers >= 0.2 && < 0.6 @@ -44,3 +42,4 @@ hs-source-dirs: src ghc-options: -Wall+ default-language: Haskell2010
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 4.19.2+version: 5 license: BSD2 cabal-version: 1.18 license-file: LICENSE@@ -10,11 +10,9 @@ homepage: http://github.com/ekmett/lens/ bug-reports: http://github.com/ekmett/lens/issues copyright: Copyright (C) 2012-2016 Edward A. Kmett-build-type: Custom+build-type: Simple -- build-tools: cpphs-tested-with: GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4+tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2@@ -97,7 +95,6 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). extra-source-files:- .travis.yml .gitignore .hlint.yaml .vim.custom@@ -113,9 +110,6 @@ lens-properties/LICENSE lens-properties/Setup.hs lens-properties/lens-properties.cabal- travis/cabal-apt-install- travis/config- Warning.hs AUTHORS.markdown CHANGELOG.markdown README.markdown@@ -127,13 +121,6 @@ type: git location: https://github.com/ekmett/lens.git -custom-setup- setup-depends:- Cabal >= 1.10 && <3.3,- base >= 4.5 && <5,- cabal-doctest >= 1 && <1.1,- filepath- -- Enable benchmarking against Neil Mitchell's uniplate library for comparative performance analysis. Defaults to being turned off to avoid -- the extra dependency. --@@ -152,21 +139,11 @@ manual: True default: True --- Some 7.6.1-rc1 users report their TH still uses old style inline pragmas. This lets them turn on inlining.-flag old-inline-pragmas- default: False- manual: True- -- Make the test suites dump their template-haskell splices. flag dump-splices default: False manual: True --- You can disable the doctests test suite with -f-test-doctests-flag test-doctests- default: True- manual: True- -- You can disable the hunit test suite with -f-test-hunit flag test-hunit default: True@@ -181,11 +158,6 @@ default: True manual: True --- Disallow unsafeCoerce-flag safe- default: False- manual: True- -- Assert that we are trustworthy when we can flag trustworthy default: True@@ -198,35 +170,40 @@ library build-depends:- array >= 0.3.0.2 && < 0.6,- base >= 4.5 && < 5,- base-orphans >= 0.5.2 && < 1,- bifunctors >= 5.1 && < 6,- bytestring >= 0.9.2.1 && < 0.11,- call-stack >= 0.1 && < 0.3,- comonad >= 4 && < 6,- contravariant >= 1.3 && < 2,- containers >= 0.4.0 && < 0.7,- distributive >= 0.3 && < 1,- filepath >= 1.2.0.0 && < 1.5,- free >= 4 && < 6,+ array >= 0.5.0.0 && < 0.6,+ assoc >= 1.0.2 && < 1.1,+ base >= 4.7 && < 5,+ base-orphans >= 0.5.2 && < 1,+ bifunctors >= 5.1 && < 6,+ bytestring >= 0.10.4.0 && < 0.12,+ call-stack >= 0.1 && < 0.4,+ comonad >= 5.0.7 && < 6,+ containers >= 0.5.5.1 && < 0.7,+ contravariant >= 1.3 && < 2,+ distributive >= 0.3 && < 1,+ exceptions >= 0.1.1 && < 1,+ filepath >= 1.2.0.0 && < 1.5,+ free >= 5.1.5 && < 6, ghc-prim,- hashable >= 1.1.2.3 && < 1.4,- kan-extensions >= 5 && < 6,- exceptions >= 0.1.1 && < 1,- mtl >= 2.0.1 && < 2.3,- parallel >= 3.1.0.1 && < 3.3,- profunctors >= 5.2.1 && < 6,- reflection >= 2.1 && < 3,- semigroupoids >= 5 && < 6,- tagged >= 0.4.4 && < 1,- template-haskell >= 2.4 && < 2.17,- th-abstraction >= 0.3 && < 0.4,- text >= 0.11 && < 1.3,- transformers >= 0.2 && < 0.6,- transformers-compat >= 0.4 && < 1,- unordered-containers >= 0.2.4 && < 0.3,- vector >= 0.9 && < 0.13+ hashable >= 1.1.2.3 && < 1.4,+ indexed-traversable >= 0.1 && < 0.2,+ indexed-traversable-instances >= 0.1 && < 0.2,+ kan-extensions >= 5 && < 6,+ mtl >= 2.0.1 && < 2.3,+ parallel >= 3.1.0.1 && < 3.3,+ profunctors >= 5.5.2 && < 6,+ reflection >= 2.1 && < 3,+ semigroupoids >= 5 && < 6,+ strict >= 0.4 && < 0.5,+ tagged >= 0.4.4 && < 1,+ template-haskell >= 2.9.0.0 && < 2.18,+ text >= 1.2.3.0 && < 1.3,+ th-abstraction >= 0.4.1 && < 0.5,+ these >= 1.1.1.1 && < 1.2,+ transformers >= 0.3.0.0 && < 0.6,+ transformers-compat >= 0.4 && < 1,+ unordered-containers >= 0.2.10 && < 0.3,+ vector >= 0.9 && < 0.13 if !impl(ghc >= 8.0) build-depends:@@ -238,13 +215,12 @@ nats >= 0.1 && < 1.2, void >= 0.5 && < 1 - if !impl(ghc >= 7.8)- build-depends:- type-equality >= 1 && < 2+ -- Control.Lens as the first module, so cabal repl loads it.+ exposed-modules:+ Control.Lens exposed-modules: Control.Exception.Lens- Control.Lens Control.Lens.At Control.Lens.Combinators Control.Lens.Cons@@ -274,10 +250,10 @@ Control.Lens.Internal.List Control.Lens.Internal.Magma Control.Lens.Internal.Prism+ Control.Lens.Internal.Profunctor Control.Lens.Internal.Review Control.Lens.Internal.Setter Control.Lens.Internal.TH- Control.Lens.Internal.Typeable Control.Lens.Internal.Zoom Control.Lens.Iso Control.Lens.Lens@@ -285,6 +261,7 @@ Control.Lens.Operators Control.Lens.Plated Control.Lens.Prism+ Control.Lens.Profunctor Control.Lens.Reified Control.Lens.Review Control.Lens.Setter@@ -331,22 +308,13 @@ Control.Lens.Internal.Prelude Paths_lens - if flag(safe)- cpp-options: -DSAFE=1-- if flag(trustworthy) && impl(ghc>=7.2)+ if flag(trustworthy) && impl(ghc) other-extensions: Trustworthy cpp-options: -DTRUSTWORTHY=1 - if flag(old-inline-pragmas) && impl(ghc>=7.6.0.20120810)- cpp-options: -DOLD_INLINE_PRAGMAS=1- if flag(inlining) cpp-options: -DINLINING - if impl(ghc<7.4)- ghc-options: -fno-spec-constr-count- if impl(ghc >= 7.10) ghc-options: -fno-warn-trustworthy-safe @@ -354,10 +322,12 @@ ghc-options: -Wno-missing-pattern-synonym-signatures ghc-options: -Wno-redundant-constraints - if flag(j) && impl(ghc>=7.8)+ if flag(j) ghc-options: -j4 ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type hs-source-dirs: src @@ -365,15 +335,24 @@ default-language: Haskell2010 + -- future proof, whether the field will be comma separated or not.+ x-docspec-extra-packages: simple-reflect+ x-docspec-extra-packages: deepseq+ -- Verify that Template Haskell expansion works test-suite templates type: exitcode-stdio-1.0 main-is: templates.hs- other-modules: T799+ other-modules:+ T799+ T917 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 + if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type+ if flag(dump-splices) ghc-options: -ddump-splices @@ -424,40 +403,17 @@ test-framework >= 0.6, test-framework-hunit >= 0.2 --- Verify the results of the examples+-- We need this dummy test-suite to add simple-reflect to the install plan+--+-- When cabal-install's extra-packages support becomes widely available+-- (i.e. after 3.4 release), we can remove this test-suite. test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs- ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010- x-doctest-options: --fast - if flag(trustworthy) && impl(ghc>=7.2)- other-extensions: Trustworthy- cpp-options: -DTRUSTWORTHY=1-- if !flag(test-doctests)- buildable: False- else- build-depends:- base,- bytestring,- containers,- directory >= 1.0,- deepseq,- doctest >= 0.11.4 && < 0.12 || >= 0.13 && < 0.17,- filepath,- generic-deriving,- lens,- mtl,- nats,- parallel,- semigroups >= 0.9,- simple-reflect >= 0.3.1,- text,- unordered-containers,- vector+ build-depends: base, deepseq, simple-reflect >= 0.3.1 -- Basic benchmarks for the uniplate-style combinators benchmark plated
src/Control/Exception/Lens.hs view
@@ -68,9 +68,7 @@ -- ** Arithmetic Exceptions , AsArithException(..) , _Overflow, _Underflow, _LossOfPrecision, _DivideByZero, _Denormal-#if MIN_VERSION_base(4,6,0) , _RatioZeroDenominator-#endif #if __GLASGOW_HASKELL__ >= 710 , pattern ArithException_ , pattern Overflow_@@ -213,12 +211,10 @@ #endif ) -#ifdef HLINT-{-# ANN module "HLint: ignore Use Control.Exception.catch" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens+-- >>> import Control.Applicative -- >>> :m + Control.Exception Control.Monad Data.List Prelude ------------------------------------------------------------------------------@@ -632,10 +628,7 @@ Denormal_ = review _Denormal () #endif -#if MIN_VERSION_base(4,6,0)--- | Added in @base@ 4.6 in response to this libraries discussion:------ <http://haskell.1045720.n5.nabble.com/Data-Ratio-and-exceptions-td5711246.html>+-- | -- -- @ -- '_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator'@@ -654,8 +647,6 @@ #if __GLASGOW_HASKELL__ >= 710 pattern RatioZeroDenominator_ <- (has _RatioZeroDenominator -> True) where RatioZeroDenominator_ = review _RatioZeroDenominator ()-#endif- #endif ----------------------------------------------------------------------------
src/Control/Lens.hs view
@@ -94,7 +94,3 @@ import Control.Lens.Type import Control.Lens.Wrapped import Control.Lens.Zoom--#ifdef HLINT-{-# ANN module "HLint: ignore Use import/export shortcut" #-}-#endif
src/Control/Lens/At.hs view
@@ -50,30 +50,42 @@ import Control.Lens.Traversal import Control.Lens.Lens import Control.Lens.Setter-import Control.Lens.Type import Control.Lens.Indexed+import Control.Monad (guard) import Data.Array.IArray as Array import Data.Array.Unboxed-import Data.ByteString as StrictB-import Data.ByteString.Lazy as LazyB+import qualified Data.ByteString as StrictB+import qualified Data.ByteString.Lazy as LazyB import Data.Complex+import Data.Functor (($>)) import Data.Hashable-import Data.HashMap.Lazy as HashMap-import Data.HashSet as HashSet+import qualified Data.HashMap.Lazy as HashMap+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashSet as HashSet+import Data.HashSet (HashSet) import Data.Int-import Data.IntMap as IntMap-import Data.IntSet as IntSet-import Data.Map as Map-import Data.Set as Set-import Data.Sequence as Seq-import Data.Text as StrictT-import Data.Text.Lazy as LazyT+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (isJust)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+import qualified Data.Text as StrictT+import qualified Data.Text.Lazy as LazyT import Data.Tree-import Data.Vector as Vector hiding (indexed)-import Data.Vector.Primitive as Prim-import Data.Vector.Storable as Storable-import Data.Vector.Unboxed as Unboxed hiding (indexed)+import qualified Data.Vector as Vector+import qualified Data.Vector.Primitive as Prim+import Data.Vector.Primitive (Prim)+import qualified Data.Vector.Storable as Storable+import qualified Data.Vector.Unboxed as Unboxed+import Data.Vector.Unboxed (Unbox) import Data.Word+import Foreign.Storable (Storable) type family Index (s :: *) :: * type instance Index (e -> a) = e@@ -112,6 +124,9 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import qualified Data.IntSet as IntSet+-- >>> import qualified Data.Sequence as Seq+-- >>> import qualified Data.Map as Map -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -152,18 +167,38 @@ {-# INLINE icontains #-} instance Contains IntSet where- contains k f s = f (IntSet.member k s) <&> \b ->- if b then IntSet.insert k s else IntSet.delete k s+#if MIN_VERSION_containers(0,6,3)+ contains k f = IntSet.alterF f k+#else+ -- This is a flipped copy of the implementation of `IntSet.alterF`. Unlike a+ -- `Set`, we don't have to worry about expensive comparisons from descending+ -- multiple times into an `IntSet`. We are careful to share the results of+ -- insertion or deletion across multiple positions in the `Functor`.+ contains k f s = fmap choose (f member_)+ where+ member_ = IntSet.member k s++ (inserted, deleted)+ | member_ = (s, IntSet.delete k s)+ | otherwise = (IntSet.insert k s, s)++ choose True = inserted+ choose False = deleted+#endif {-# INLINE contains #-} instance Ord a => Contains (Set a) where+#if MIN_VERSION_containers(0,6,3)+ contains k f = Set.alterF f k+#else contains k f s = f (Set.member k s) <&> \b -> if b then Set.insert k s else Set.delete k s+#endif {-# INLINE contains #-} instance (Eq a, Hashable a) => Contains (HashSet a) where- contains k f s = f (HashSet.member k s) <&> \b ->- if b then HashSet.insert k s else HashSet.delete k s+ contains k f s = HashSet.fromMap <$>+ HashMap.alterF (fmap guard . f . isJust) k (HashSet.toMap s) {-# INLINE contains #-} -- | This provides a common notion of a value at an index that is shared by both 'Ixed' and 'At'.@@ -190,7 +225,7 @@ -- >>> Seq.fromList [] ^? ix 2 -- Nothing ix :: Index m -> Traversal' m (IxValue m)- default ix :: (Applicative f, At m) => Index m -> LensLike' f m (IxValue m)+ default ix :: At m => Index m -> Traversal' m (IxValue m) ix = ixAt {-# INLINE ix #-} @@ -224,8 +259,8 @@ type instance IxValue (Maybe a) = a instance Ixed (Maybe a) where- ix () f (Just a) = Just <$> f a- ix () _ Nothing = pure Nothing+ ix ~() f (Just a) = Just <$> f a+ ix ~() _ Nothing = pure Nothing {-# INLINE ix #-} type instance IxValue [a] = a@@ -247,7 +282,7 @@ type instance IxValue (Identity a) = a instance Ixed (Identity a) where- ix () f (Identity a) = Identity <$> f a+ ix ~() f (Identity a) = Identity <$> f a {-# INLINE ix #-} type instance IxValue (Tree a) = a@@ -290,21 +325,21 @@ type instance IxValue (Set k) = () instance Ord k => Ixed (Set k) where ix k f m = if Set.member k m- then f () <&> \() -> Set.insert k m+ then f () $> m else pure m {-# INLINE ix #-} type instance IxValue IntSet = () instance Ixed IntSet where ix k f m = if IntSet.member k m- then f () <&> \() -> IntSet.insert k m+ then f () $> m else pure m {-# INLINE ix #-} type instance IxValue (HashSet k) = () instance (Eq k, Hashable k) => Ixed (HashSet k) where ix k f m = if HashSet.member k m- then f () <&> \() -> HashSet.insert k m+ then f () $> m else pure m {-# INLINE ix #-} @@ -441,7 +476,7 @@ {-# INLINE iat #-} instance At (Maybe a) where- at () f = f+ at ~() f = f {-# INLINE at #-} instance At (IntMap a) where@@ -467,70 +502,79 @@ {-# INLINE at #-} instance (Eq k, Hashable k) => At (HashMap k a) where- at k f m = f mv <&> \r -> case r of- Nothing -> maybe m (const (HashMap.delete k m)) mv- Just v' -> HashMap.insert k v' m- where mv = HashMap.lookup k m+ at k f = HashMap.alterF f k {-# INLINE at #-} instance At IntSet where- at k f m = f mv <&> \r -> case r of- Nothing -> maybe m (const (IntSet.delete k m)) mv- Just () -> IntSet.insert k m- where mv = if IntSet.member k m then Just () else Nothing+ -- This is a gently modified copy of the implementation of `IntSet.alterF`.+ -- Unlike a `Set`, we don't have to worry about expensive comparisons from+ -- descending multiple times into an `IntSet`. We are careful to share the+ -- results of insertion or deletion across multiple positions in the+ -- `Functor`.+ at k f s = fmap choose (f (guard member_))+ where+ member_ = IntSet.member k s++ (inserted, deleted)+ | member_ = (s, IntSet.delete k s)+ | otherwise = (IntSet.insert k s, s)++ choose (Just ~()) = inserted+ choose Nothing = deleted {-# INLINE at #-} instance Ord k => At (Set k) where+#if MIN_VERSION_containers(0,6,3)+ at k f = Set.alterF (fmap isJust . f . guard) k+#else at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (Set.delete k m)) mv- Just () -> Set.insert k m+ Just ~() -> maybe (Set.insert k m) (const m) mv where mv = if Set.member k m then Just () else Nothing+#endif {-# INLINE at #-} instance (Eq k, Hashable k) => At (HashSet k) where- at k f m = f mv <&> \r -> case r of- Nothing -> maybe m (const (HashSet.delete k m)) mv- Just () -> HashSet.insert k m- where mv = if HashSet.member k m then Just () else Nothing+ at k f s = HashSet.fromMap <$> HashMap.alterF f k (HashSet.toMap s) {-# INLINE at #-} -- | @'ix' :: 'Int' -> 'Traversal'' (a,a) a@ type instance IxValue (a,a2) = a instance (a~a2) => Ixed (a,a2) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a) a@ type instance IxValue (a,a2,a3) = a instance (a~a2, a~a3) => Ixed (a,a2,a3) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a) a@ type instance IxValue (a,a2,a3,a4) = a instance (a~a2, a~a3, a~a4) => Ixed (a,a2,a3,a4) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5) = a instance (a~a2, a~a3, a~a4, a~a5) => Ixed (a,a2,a3,a4,a5) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6) => Ixed (a,a2,a3,a4,a5,a6) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6,a7) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7) => Ixed (a,a2,a3,a4,a5,a6,a7) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8) => Ixed (a,a2,a3,a4,a5,a6,a7,a8) where- ix = elementOf each+ ix p = elementOf each p -- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a,a) a@ type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8,a9) = a instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9) => Ixed (a,a2,a3,a4,a5,a6,a7,a8,a9) where- ix = elementOf each+ ix p = elementOf each p
src/Control/Lens/Combinators.hs view
@@ -94,18 +94,18 @@ , (.@=) , (.@~) , (^#)- , ( #~ )- , ( #%~ )- , ( #%%~ )- , ( #= )- , ( #%= )+ , (#~)+ , (#%~)+ , (#%%~)+ , (#=)+ , (#%=) , (<#%~) , (<#%=)- , ( #%%= )+ , (#%%=) , (<#~) , (<#=) , (...)- , ( # )+ , (#) , (%~) , (.~) , (?~)
src/Control/Lens/Cons.hs view
@@ -50,12 +50,12 @@ import Control.Lens.Review import Control.Lens.Tuple import Control.Lens.Type-import Control.Lens.Internal.Coerce import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB+import Data.Coerce import Data.Monoid import qualified Data.Sequence as Seq-import Data.Sequence hiding ((<|), (|>), (:<), (:>))+import Data.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), viewl, viewr) import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT import Data.Vector (Vector)@@ -70,13 +70,12 @@ import Control.Applicative (ZipList(..)) import Prelude -#ifdef HLINT-{-# ANN module "HLint: ignore Eta reduce" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq+-- >>> import qualified Data.Vector as Vector+-- >>> import qualified Data.Text.Lazy as LazyT -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -125,7 +124,7 @@ instance Cons (ZipList a) (ZipList b) a b where _Cons = withPrism listCons $ \listReview listPreview ->- prism (coerce' listReview) (coerce' listPreview) where+ prism (coerce listReview) (coerce listPreview) where listCons :: Prism [a] [b] (a, [a]) (b, [b]) listCons = _Cons@@ -359,7 +358,7 @@ instance Snoc (ZipList a) (ZipList b) a b where _Snoc = withPrism listSnoc $ \listReview listPreview ->- prism (coerce' listReview) (coerce' listPreview) where+ prism (coerce listReview) (coerce listPreview) where listSnoc :: Prism [a] [b] ([a], a) ([b], b) listSnoc = _Snoc@@ -545,5 +544,5 @@ -- >>> unsnoc (Seq.fromList []) -- Nothing unsnoc :: Snoc s s a a => s -> Maybe (s, a)-unsnoc s = simply preview _Snoc s+unsnoc = simply preview _Snoc {-# INLINE unsnoc #-}
src/Control/Lens/Each.hs view
@@ -35,16 +35,16 @@ import Control.Lens.Internal.Prelude import Data.Array.Unboxed as Unboxed import Data.Array.IArray as IArray-import Data.ByteString as StrictB-import Data.ByteString.Lazy as LazyB+import qualified Data.ByteString as StrictB+import qualified Data.ByteString.Lazy as LazyB import Data.Complex-import Data.HashMap.Lazy as HashMap-import Data.IntMap as IntMap-import Data.Map as Map-import Data.Sequence as Seq+import Data.HashMap.Lazy (HashMap)+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Sequence (Seq) import Data.Text.Lens (text)-import Data.Text as StrictT-import Data.Text.Lazy as LazyT+import qualified Data.Text as StrictT+import qualified Data.Text.Lazy as LazyT import Data.Tree as Tree import Data.Vector.Generic.Lens (vectorTraverse) import qualified Data.Vector as Vector@@ -55,6 +55,8 @@ import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import Data.Word+import qualified Data.Strict as S+import Data.These (These (..)) -- $setup -- >>> :set -XNoOverloadedStrings@@ -221,3 +223,37 @@ instance (Ix i, IArray UArray a, IArray UArray b, i ~ j) => Each (UArray i a) (UArray j b) a b where each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr) {-# INLINE each #-}++-------------------------------------------------------------------------------+-- strict+-------------------------------------------------------------------------------++-- | @since 4.20+instance (a ~ a', b ~ b') => Each (S.Either a a') (S.Either b b') a b where+ each f (S.Left x) = S.Left <$> f x+ each f (S.Right x) = S.Right <$> f x+ {-# INLINE each #-}++-- | @since 4.20+instance (a~a', b~b') => Each (S.Pair a a') (S.Pair b b') a b where+ each f (a S.:!: b) = (S.:!:) <$> f a <*> f b+ {-# INLINE each #-}++-- | @since 4.20+instance Each (S.Maybe a) (S.Maybe b) a b++-- | @since 4.20+instance (a ~ a', b ~ b') => Each (S.These a a') (S.These b b') a b where+ each f (S.This a) = S.This <$> f a+ each f (S.That b) = S.That <$> f b+ each f (S.These a b) = S.These <$> f a <*> f b++-------------------------------------------------------------------------------+-- these+-------------------------------------------------------------------------------++-- | @since 4.20+instance (a ~ a', b ~ b') => Each (These a a') (These b b') a b where+ each f (This a) = This <$> f a+ each f (That b) = That <$> f b+ each f (These a b) = These <$> f a <*> f b
src/Control/Lens/Empty.hs view
@@ -37,26 +37,37 @@ import Control.Lens.Prism import Control.Lens.Internal.Prelude as Prelude import Control.Lens.Review-import Data.ByteString as StrictB-import Data.ByteString.Lazy as LazyB-import Data.HashMap.Lazy as HashMap-import Data.HashSet as HashSet-import Data.IntMap as IntMap-import Data.IntSet as IntSet+import qualified Data.ByteString as StrictB+import qualified Data.ByteString.Lazy as LazyB+import qualified Data.HashMap.Lazy as HashMap+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashSet as HashSet+import Data.HashSet (HashSet)+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet) import Data.Monoid-import Data.Map as Map+import qualified Data.Map as Map+import Data.Map (Map) import Data.Maybe import qualified Data.Sequence as Seq-import Data.Set as Set-import Data.Text as StrictT-import Data.Text.Lazy as LazyT-import Data.Vector as Vector-import Data.Vector.Unboxed as Unboxed-import Data.Vector.Storable as Storable+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Text as StrictT+import qualified Data.Text.Lazy as LazyT+import qualified Data.Vector as Vector+import qualified Data.Vector.Unboxed as Unboxed+import Data.Vector.Unboxed (Unbox)+import qualified Data.Vector.Storable as Storable+import Foreign.Storable (Storable) #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) import GHC.Event #endif++-- $setup+-- >>> import Control.Lens class AsEmpty a where -- |
src/Control/Lens/Equality.hs view
@@ -3,11 +3,10 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-}+{-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -54,11 +53,6 @@ import Data.Kind (Type) #endif -#ifdef HLINT-{-# ANN module "HLint: ignore Use id" #-}-{-# ANN module "HLint: ignore Eta reduce" #-}-#endif- -- $setup -- >>> import Control.Lens @@ -73,11 +67,7 @@ Identical :: Identical a b a b -- | When you see this as an argument to a function, it expects an 'Equality'.-#if __GLASGOW_HASKELL__ >= 706-type AnEquality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = Identical a (Proxy b) a (Proxy b) -> Identical a (Proxy b) s (Proxy t)-#else type AnEquality s t a b = Identical a (Proxy b) a (Proxy b) -> Identical a (Proxy b) s (Proxy t)-#endif -- | A 'Simple' 'AnEquality'. type AnEquality' s a = AnEquality s s a a@@ -101,10 +91,8 @@ -- | We can use 'Equality' to do substitution into anything. #if __GLASGOW_HASKELL__ >= 800 mapEq :: forall k1 k2 (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> Type) . AnEquality s t a b -> f s -> f a-#elif __GLASGOW_HASKELL__ >= 706-mapEq :: forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a #else-mapEq :: AnEquality s t a b -> f s -> f a+mapEq :: forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a #endif mapEq l r = substEq l r {-# INLINE mapEq #-}
src/Control/Lens/Fold.hs view
@@ -175,6 +175,7 @@ -- >>> import Control.Lens.Extras (is) -- >>> import Data.Function -- >>> import Data.List.Lens+-- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> import Control.DeepSeq (NFData (..), force)@@ -187,13 +188,6 @@ -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force -#ifdef HLINT-{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Use camelCase" #-}-{-# ANN module "HLint: ignore Use curry" #-}-{-# ANN module "HLint: ignore Use fmap" #-}-#endif- infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! --------------------------@@ -306,7 +300,7 @@ -- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1)) -- [10,9,8,7,6,5,4,3,2,1] unfolded :: (b -> Maybe (a, b)) -> Fold b a-unfolded f g b0 = go b0 where+unfolded f g = go where go b = case f b of Just (a, b') -> g a *> go b' Nothing -> noEffect@@ -322,7 +316,7 @@ -- 'iterated' :: (a -> a) -> 'Fold1' a a -- @ iterated :: Apply f => (a -> a) -> LensLike' f a a-iterated f g a0 = go a0 where+iterated f g = go where go a = g a .> go (f a) {-# INLINE iterated #-}
src/Control/Lens/Getter.hs view
@@ -4,11 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE NoPolyKinds #-}-{-# LANGUAGE NoDataKinds #-}-#endif- -- Disable the warnings generated by 'to', 'ito', 'like', 'ilike'. -- These functions are intended to produce 'Getters'. Without this constraint -- users would get warnings when annotating types at uses of these functions.@@ -98,7 +93,9 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Control.Monad.State -- >>> import Data.List.Lens+-- >>> import Data.Semigroup (Semigroup (..)) -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
src/Control/Lens/Indexed.hs view
@@ -1,12 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- vector, hashable@@ -39,9 +34,12 @@ , indexing64 -- * Indexed Functors , FunctorWithIndex(..)+ -- ** Indexed Functor Combinators+ , imapped -- * Indexed Foldables , FoldableWithIndex(..) -- ** Indexed Foldable Combinators+ , ifolded , iany , iall , inone, none@@ -63,6 +61,7 @@ -- * Indexed Traversables , TraversableWithIndex(..) -- * Indexed Traversable Combinators+ , itraversed , ifor , imapM , iforM@@ -78,53 +77,38 @@ import Prelude () -import Control.Applicative.Backwards-import Control.Comonad.Cofree-import Control.Comonad.Trans.Traced-import Control.Monad (void, liftM)-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Lazy as Lazy-import Control.Monad.Free+import Data.Functor.WithIndex+import Data.Foldable.WithIndex+import Data.Traversable.WithIndex+ import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal.Fold import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude-import Control.Lens.Internal.Level-import Control.Lens.Internal.Magma import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type-import Data.Array (Array)-import qualified Data.Array as Array-import Data.Foldable-import Data.Functor.Constant (Constant (..))-import Data.Functor.Product-import Data.Functor.Reverse-import Data.Functor.Sum-import Data.HashMap.Lazy as HashMap-import Data.IntMap as IntMap-import Data.Ix (Ix)-import Data.Map as Map-import Data.Monoid hiding (Sum, Product) import Data.Reflection-import Data.Sequence hiding ((:<), index)-import Data.Tree-import Data.Tuple (swap)++import Data.HashMap.Lazy (HashMap)+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Sequence (Seq) import Data.Vector (Vector)-import qualified Data.Vector as V-import GHC.Generics -#ifdef HLINT-{-# ANN module "HLint: ignore Use fmap" #-}-#endif+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Vector as Vector infixr 9 <.>, <., .> -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import qualified Data.Map as Map -- | Compose an 'Indexed' function with a non-indexed function. --@@ -215,498 +199,46 @@ -- FunctorWithIndex ------------------------------------------------------------------------------- --- | A 'Functor' with an additional index.------ Instances must satisfy a modified form of the 'Functor' laws:+-- | The 'IndexedSetter' for a 'FunctorWithIndex'. ----- @--- 'imap' f '.' 'imap' g ≡ 'imap' (\\i -> f i '.' g i)--- 'imap' (\\_ a -> a) ≡ 'id'--- @-class Functor f => FunctorWithIndex i f | f -> i where- -- | Map with access to the index.- imap :: (i -> a -> b) -> f a -> f b- default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b- imap = iover itraversed- {-# INLINE imap #-}-- -- | The 'IndexedSetter' for a 'FunctorWithIndex'.- --- -- If you don't need access to the index, then 'mapped' is more flexible in what it accepts.- imapped :: IndexedSetter i (f a) (f b) a b- imapped = conjoined mapped (isets imap)- {-# INLINE imapped #-}+-- If you don't need access to the index, then 'mapped' is more flexible in what it accepts.+imapped :: FunctorWithIndex i f => IndexedSetter i (f a) (f b) a b+imapped = conjoined mapped (isets imap)+{-# INLINE imapped #-} ------------------------------------------------------------------------------- -- FoldableWithIndex ------------------------------------------------------------------------------- --- | A container that supports folding with an additional index.-class Foldable f => FoldableWithIndex i f | f -> i where- --- -- | Fold a container by mapping value to an arbitrary 'Monoid' with access to the index @i@.- --- -- When you don't need access to the index then 'foldMap' is more flexible in what it accepts.- --- -- @- -- 'foldMap' ≡ 'ifoldMap' '.' 'const'- -- @- ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m-#ifndef HLINT- default ifoldMap :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m- ifoldMap = ifoldMapOf itraversed- {-# INLINE ifoldMap #-}-#endif-- -- | The 'IndexedFold' of a 'FoldableWithIndex' container.- --- -- @'ifolded' '.' 'asIndex'@ is a fold over the keys of a 'FoldableWithIndex'.- --- -- >>> Data.Map.fromList [(2, "hello"), (1, "world")]^..ifolded.asIndex- -- [1,2]- ifolded :: IndexedFold i (f a) a- ifolded = conjoined folded $ \f -> phantom . getFolding . ifoldMap (\i -> Folding #. indexed f i)- {-# INLINE ifolded #-}-- -- | Right-associative fold of an indexed container with access to the index @i@.- --- -- When you don't need access to the index then 'Data.Foldable.foldr' is more flexible in what it accepts.- --- -- @- -- 'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const'- -- @- ifoldr :: (i -> a -> b -> b) -> b -> f a -> b- ifoldr f z t = appEndo (ifoldMap (\i -> Endo #. f i) t) z- {-# INLINE ifoldr #-}-- -- | Left-associative fold of an indexed container with access to the index @i@.- --- -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts.- --- -- @- -- 'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const'- -- @- ifoldl :: (i -> b -> a -> b) -> b -> f a -> b- ifoldl f z t = appEndo (getDual (ifoldMap (\i -> Dual #. Endo #. flip (f i)) t)) z- {-# INLINE ifoldl #-}-- -- | /Strictly/ fold right over the elements of a structure with access to the index @i@.- --- -- When you don't need access to the index then 'foldr'' is more flexible in what it accepts.- --- -- @- -- 'foldr'' ≡ 'ifoldr'' '.' 'const'- -- @- ifoldr' :: (i -> a -> b -> b) -> b -> f a -> b- ifoldr' f z0 xs = ifoldl f' id xs z0- where f' i k x z = k $! f i x z- {-# INLINE ifoldr' #-}-- -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/.- --- -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts.- --- -- @- -- 'Control.Lens.Fold.foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const'- -- @- ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b- ifoldl' f z0 xs = ifoldr f' id xs z0- where f' i x k z = k $! f i z x- {-# INLINE ifoldl' #-}---- | Return whether or not any element in a container satisfies a predicate, with access to the index @i@.------ When you don't need access to the index then 'any' is more flexible in what it accepts.------ @--- 'any' ≡ 'iany' '.' 'const'--- @-iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool-iany f = getAny #. ifoldMap (\i -> Any #. f i)-{-# INLINE iany #-}---- | Return whether or not all elements in a container satisfy a predicate, with access to the index @i@.------ When you don't need access to the index then 'all' is more flexible in what it accepts.------ @--- 'all' ≡ 'iall' '.' 'const'--- @-iall :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool-iall f = getAll #. ifoldMap (\i -> All #. f i)-{-# INLINE iall #-}---- | Return whether or not none of the elements in a container satisfy a predicate, with access to the index @i@.------ When you don't need access to the index then 'none' is more flexible in what it accepts.------ @--- 'none' ≡ 'inone' '.' 'const'--- 'inone' f ≡ 'not' '.' 'iany' f--- @-inone :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool-inone f = not . iany f-{-# INLINE inone #-}---- | Determines whether no elements of the structure satisfy the predicate.------ @--- 'none' f ≡ 'not' '.' 'any' f--- @-none :: Foldable f => (a -> Bool) -> f a -> Bool-none f = not . Data.Foldable.any f-{-# INLINE none #-}---- | Traverse elements with access to the index @i@, discarding the results.------ When you don't need access to the index then 'traverse_' is more flexible in what it accepts.------ @--- 'traverse_' l = 'itraverse' '.' 'const'--- @-itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f ()-itraverse_ f = void . getTraversed #. ifoldMap (\i -> Traversed #. f i)-{-# INLINE itraverse_ #-}---- | Traverse elements with access to the index @i@, discarding the results (with the arguments flipped).------ @--- 'ifor_' ≡ 'flip' 'itraverse_'--- @------ When you don't need access to the index then 'for_' is more flexible in what it accepts.------ @--- 'for_' a ≡ 'ifor_' a '.' 'const'--- @-ifor_ :: (FoldableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f ()-ifor_ = flip itraverse_-{-# INLINE ifor_ #-}---- | Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index,--- discarding the results.------ When you don't need access to the index then 'Control.Lens.Fold.mapMOf_' is more flexible in what it accepts.------ @--- 'mapM_' ≡ 'imapM' '.' 'const'--- @-imapM_ :: (FoldableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m ()-imapM_ f = liftM skip . getSequenced #. ifoldMap (\i -> Sequenced #. f i)-{-# INLINE imapM_ #-}---- | Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index,--- discarding the results (with the arguments flipped).------ @--- 'iforM_' ≡ 'flip' 'imapM_'--- @------ When you don't need access to the index then 'Control.Lens.Fold.forMOf_' is more flexible in what it accepts.------ @--- 'Control.Lens.Fold.forMOf_' l a ≡ 'iforMOf' l a '.' 'const'--- @-iforM_ :: (FoldableWithIndex i t, Monad m) => t a -> (i -> a -> m b) -> m ()-iforM_ = flip imapM_-{-# INLINE iforM_ #-}---- | Concatenate the results of a function of the elements of an indexed container with access to the index.------ When you don't need access to the index then 'concatMap' is more flexible in what it accepts.------ @--- 'concatMap' ≡ 'iconcatMap' '.' 'const'--- 'iconcatMap' ≡ 'ifoldMap'--- @-iconcatMap :: FoldableWithIndex i f => (i -> a -> [b]) -> f a -> [b]-iconcatMap = ifoldMap-{-# INLINE iconcatMap #-}---- | Searches a container with a predicate that is also supplied the index, returning the left-most element of the structure--- matching the predicate, or 'Nothing' if there is no such element.------ When you don't need access to the index then 'find' is more flexible in what it accepts.------ @--- 'find' ≡ 'ifind' '.' 'const'--- @-ifind :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Maybe (i, a)-ifind p = ifoldr (\i a y -> if p i a then Just (i, a) else y) Nothing-{-# INLINE ifind #-}---- | Monadic fold right over the elements of a structure with an index.------ When you don't need access to the index then 'foldrM' is more flexible in what it accepts.------ @--- 'foldrM' ≡ 'ifoldrM' '.' 'const'--- @-ifoldrM :: (FoldableWithIndex i f, Monad m) => (i -> a -> b -> m b) -> b -> f a -> m b-ifoldrM f z0 xs = ifoldl f' return xs z0- where f' i k x z = f i x z >>= k-{-# INLINE ifoldrM #-}---- | Monadic fold over the elements of a structure with an index, associating to the left.------ When you don't need access to the index then 'foldlM' is more flexible in what it accepts.------ @--- 'foldlM' ≡ 'ifoldlM' '.' 'const'--- @-ifoldlM :: (FoldableWithIndex i f, Monad m) => (i -> b -> a -> m b) -> b -> f a -> m b-ifoldlM f z0 xs = ifoldr f' return xs z0- where f' i x k z = f i z x >>= k-{-# INLINE ifoldlM #-}---- | Extract the key-value pairs from a structure.+-- | The 'IndexedFold' of a 'FoldableWithIndex' container. ----- When you don't need access to the indices in the result, then 'Data.Foldable.toList' is more flexible in what it accepts.+-- @'ifolded' '.' 'asIndex'@ is a fold over the keys of a 'FoldableWithIndex'. ----- @--- 'Data.Foldable.toList' ≡ 'Data.List.map' 'snd' '.' 'itoList'--- @-itoList :: FoldableWithIndex i f => f a -> [(i,a)]-itoList = ifoldr (\i c -> ((i,c):)) []-{-# INLINE itoList #-}+-- >>> Data.Map.fromList [(2, "hello"), (1, "world")]^..ifolded.asIndex+-- [1,2]+ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a+ifolded = conjoined folded $ \f -> phantom . getFolding . ifoldMap (\i -> Folding #. indexed f i)+{-# INLINE ifolded #-} ------------------------------------------------------------------------------- -- TraversableWithIndex ------------------------------------------------------------------------------- --- | A 'Traversable' with an additional index.------ An instance must satisfy a (modified) form of the 'Traversable' laws:------ @--- 'itraverse' ('const' 'Identity') ≡ 'Identity'--- 'fmap' ('itraverse' f) '.' 'itraverse' g ≡ 'Data.Functor.Compose.getCompose' '.' 'itraverse' (\\i -> 'Data.Functor.Compose.Compose' '.' 'fmap' (f i) '.' g i)--- @-class (FunctorWithIndex i t, FoldableWithIndex i t, Traversable t) => TraversableWithIndex i t | t -> i where- -- | Traverse an indexed container.- --- -- @- -- 'itraverse' ≡ 'itraverseOf' 'itraversed'- -- @- itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b)-#ifndef HLINT- default itraverse :: (i ~ Int, Applicative f) => (i -> a -> f b) -> t a -> f (t b)- itraverse = traversed .# Indexed- {-# INLINE itraverse #-}-#endif-- -- | The 'IndexedTraversal' of a 'TraversableWithIndex' container.- itraversed :: IndexedTraversal i (t a) (t b) a b- itraversed = conjoined traverse (itraverse . indexed)- {-# INLINE itraversed #-}---- | Traverse with an index (and the arguments flipped).------ @--- 'for' a ≡ 'ifor' a '.' 'const'--- 'ifor' ≡ 'flip' 'itraverse'--- @-ifor :: (TraversableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f (t b)-ifor = flip itraverse-{-# INLINE ifor #-}---- | Map each element of a structure to a monadic action,--- evaluate these actions from left to right, and collect the results, with access--- the index.------ When you don't need access to the index 'mapM' is more liberal in what it can accept.------ @--- 'mapM' ≡ 'imapM' '.' 'const'--- @-imapM :: (TraversableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m (t b)-imapM f = unwrapMonad #. itraverse (\i -> WrapMonad #. f i)-{-# INLINE imapM #-}---- | Map each element of a structure to a monadic action,--- evaluate these actions from left to right, and collect the results, with access--- its position (and the arguments flipped).------ @--- 'forM' a ≡ 'iforM' a '.' 'const'--- 'iforM' ≡ 'flip' 'imapM'--- @-iforM :: (TraversableWithIndex i t, Monad m) => t a -> (i -> a -> m b) -> m (t b)-iforM = flip imapM-{-# INLINE iforM #-}---- | Generalizes 'Data.Traversable.mapAccumR' to add access to the index.------ 'imapAccumROf' accumulates state from right to left.------ @--- 'Control.Lens.Traversal.mapAccumR' ≡ 'imapAccumR' '.' 'const'--- @-imapAccumR :: TraversableWithIndex i t => (i -> s -> a -> (s, b)) -> s -> t a -> (s, t b)-imapAccumR f s0 a = swap (Lazy.runState (forwards (itraverse (\i c -> Backwards (Lazy.state (\s -> swap (f i s c)))) a)) s0)-{-# INLINE imapAccumR #-}---- | Generalizes 'Data.Traversable.mapAccumL' to add access to the index.------ 'imapAccumLOf' accumulates state from left to right.------ @--- 'Control.Lens.Traversal.mapAccumLOf' ≡ 'imapAccumL' '.' 'const'--- @-imapAccumL :: TraversableWithIndex i t => (i -> s -> a -> (s, b)) -> s -> t a -> (s, t b)-imapAccumL f s0 a = swap (Lazy.runState (itraverse (\i c -> Lazy.state (\s -> swap (f i s c))) a) s0)-{-# INLINE imapAccumL #-}+-- | The 'IndexedTraversal' of a 'TraversableWithIndex' container.+itraversed :: TraversableWithIndex i t => IndexedTraversal i (t a) (t b) a b+itraversed = conjoined traverse (itraverse . indexed)+{-# INLINE [0] itraversed #-} ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- -instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where- imap f = Backwards . imap f . forwards- {-# INLINE imap #-}--instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where- ifoldMap f = ifoldMap f . forwards- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where- itraverse f = fmap Backwards . itraverse f . forwards- {-# INLINE itraverse #-}--instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where- imap f = Reverse . imap f . getReverse- {-# INLINE imap #-}--instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where- ifoldMap f = getDual . ifoldMap (\i -> Dual #. f i) . getReverse- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where- itraverse f = fmap Reverse . forwards . itraverse (\i -> Backwards . f i) . getReverse- {-# INLINE itraverse #-}--instance FunctorWithIndex () Identity where- imap f (Identity a) = Identity (f () a)- {-# INLINE imap #-}--instance FoldableWithIndex () Identity where- ifoldMap f (Identity a) = f () a- {-# INLINE ifoldMap #-}--instance TraversableWithIndex () Identity where- itraverse f (Identity a) = Identity <$> f () a- {-# INLINE itraverse #-}--instance FunctorWithIndex Void (Const e) where- imap _ (Const a) = Const a- {-# INLINE imap #-}--instance FoldableWithIndex Void (Const e) where- ifoldMap _ _ = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex Void (Const e) where- itraverse _ (Const a) = pure (Const a)- {-# INLINE itraverse #-}--instance FunctorWithIndex Void (Constant e) where- imap _ (Constant a) = Constant a- {-# INLINE imap #-}--instance FoldableWithIndex Void (Constant e) where- ifoldMap _ _ = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex Void (Constant e) where- itraverse _ (Constant a) = pure (Constant a)- {-# INLINE itraverse #-}--instance FunctorWithIndex k ((,) k) where- imap f (k,a) = (k, f k a)- {-# INLINE imap #-}--instance FoldableWithIndex k ((,) k) where- ifoldMap = uncurry- {-# INLINE ifoldMap #-}--instance TraversableWithIndex k ((,) k) where- itraverse f (k, a) = (,) k <$> f k a- {-# INLINE itraverse #-}---- | The position in the list is available as the index.-instance FunctorWithIndex Int []-instance FoldableWithIndex Int []-instance TraversableWithIndex Int [] where- itraversed = traversed- {-# INLINE itraversed #-}---- | Same instance as for @[]@.-instance FunctorWithIndex Int ZipList-instance FoldableWithIndex Int ZipList-instance TraversableWithIndex Int ZipList where- itraversed = traversed- {-# INLINE itraversed #-}--instance FunctorWithIndex Int NonEmpty-instance FoldableWithIndex Int NonEmpty-instance TraversableWithIndex Int NonEmpty where- itraverse = itraverseOf traversed- {-# INLINE itraverse #-}--instance FunctorWithIndex () Maybe where- imap f = fmap (f ())- {-# INLINE imap #-}-instance FoldableWithIndex () Maybe where- ifoldMap f = foldMap (f ())- {-# INLINE ifoldMap #-}-instance TraversableWithIndex () Maybe where- itraverse f = traverse (f ())- {-# INLINE itraverse #-}---- | The position in the 'Seq' is available as the index.-instance FunctorWithIndex Int Seq where- imap = mapWithIndex-instance FoldableWithIndex Int Seq where-#if MIN_VERSION_containers(0,5,8)- ifoldMap = foldMapWithIndex-#else- ifoldMap f = Data.Foldable.fold . mapWithIndex f-#endif- ifoldr = foldrWithIndex- ifoldl f = foldlWithIndex (flip f)- {-# INLINE ifoldl #-}-instance TraversableWithIndex Int Seq where-#if MIN_VERSION_containers(0,5,8)- itraverse = traverseWithIndex-#else- itraverse f = sequenceA . mapWithIndex f-#endif--instance FunctorWithIndex Int Vector where- imap = V.imap- {-# INLINE imap #-}-instance FoldableWithIndex Int Vector where- ifoldr = V.ifoldr- {-# INLINE ifoldr #-}- ifoldl = V.ifoldl . flip- {-# INLINE ifoldl #-}- ifoldr' = V.ifoldr'- {-# INLINE ifoldr' #-}- ifoldl' = V.ifoldl' . flip- {-# INLINE ifoldl' #-}-instance TraversableWithIndex Int Vector where- itraversed = traversed- {-# INLINE itraversed #-}--instance FunctorWithIndex Int IntMap-instance FoldableWithIndex Int IntMap-instance TraversableWithIndex Int IntMap where-#if MIN_VERSION_containers(0,5,0)- itraverse = IntMap.traverseWithKey-#else- itraverse f = sequenceA . IntMap.mapWithKey f-#endif- {-# INLINE [0] itraverse #-}+{-# RULES+"itraversed -> mapList" itraversed = sets fmap :: ASetter [a] [b] a b;+"itraversed -> imapList" itraversed = isets imap :: AnIndexedSetter Int [a] [b] a b;+"itraversed -> foldrList" itraversed = foldring foldr :: Getting (Endo r) [a] a;+"itraversed -> ifoldrList" itraversed = ifoldring ifoldr :: IndexedGetting Int (Endo r) [a] a;+ #-} {-# RULES "itraversed -> mapIntMap" itraversed = sets IntMap.map :: ASetter (IntMap a) (IntMap b) a b;@@ -715,16 +247,6 @@ "itraversed -> ifoldrIntMap" itraversed = ifoldring IntMap.foldrWithKey :: IndexedGetting Int (Endo r) (IntMap a) a; #-} -instance FunctorWithIndex k (Map k)-instance FoldableWithIndex k (Map k)-instance TraversableWithIndex k (Map k) where-#if MIN_VERSION_containers(0,5,0)- itraverse = Map.traverseWithKey-#else- itraverse f = sequenceA . Map.mapWithKey f-#endif- {-# INLINE [0] itraverse #-}- {-# RULES "itraversed -> mapMap" itraversed = sets Map.map :: ASetter (Map k a) (Map k b) a b; "itraversed -> imapMap" itraversed = isets Map.mapWithKey :: AnIndexedSetter k (Map k a) (Map k b) a b;@@ -732,12 +254,6 @@ "itraversed -> ifoldrMap" itraversed = ifoldring Map.foldrWithKey :: IndexedGetting k (Endo r) (Map k a) a; #-} -instance FunctorWithIndex k (HashMap k)-instance FoldableWithIndex k (HashMap k)-instance TraversableWithIndex k (HashMap k) where- itraverse = HashMap.traverseWithKey- {-# INLINE [0] itraverse #-}- {-# RULES "itraversed -> mapHashMap" itraversed = sets HashMap.map :: ASetter (HashMap k a) (HashMap k b) a b; "itraversed -> imapHashMap" itraversed = isets HashMap.mapWithKey :: AnIndexedSetter k (HashMap k a) (HashMap k b) a b;@@ -745,290 +261,19 @@ "itraversed -> ifoldrHashMap" itraversed = ifoldring HashMap.foldrWithKey :: IndexedGetting k (Endo r) (HashMap k a) a; #-} -instance FunctorWithIndex r ((->) r) where- imap f g x = f x (g x)- {-# INLINE imap #-}--instance FunctorWithIndex i (Level i) where- imap f = go where- go (Two n l r) = Two n (go l) (go r)- go (One i a) = One i (f i a)- go Zero = Zero- {-# INLINE imap #-}--instance FoldableWithIndex i (Level i) where- ifoldMap f = go where- go (Two _ l r) = go l `mappend` go r- go (One i a) = f i a- go Zero = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i (Level i) where- itraverse f = go where- go (Two n l r) = Two n <$> go l <*> go r- go (One i a) = One i <$> f i a- go Zero = pure Zero- {-# INLINE itraverse #-}--instance FunctorWithIndex i (Magma i t b) where- imap f (MagmaAp x y) = MagmaAp (imap f x) (imap f y)- imap _ (MagmaPure x) = MagmaPure x- imap f (MagmaFmap xy x) = MagmaFmap xy (imap f x)- imap f (Magma i a) = Magma i (f i a)- {-# INLINE imap #-}--instance FoldableWithIndex i (Magma i t b) where- ifoldMap f (MagmaAp x y) = ifoldMap f x `mappend` ifoldMap f y- ifoldMap _ MagmaPure{} = mempty- ifoldMap f (MagmaFmap _ x) = ifoldMap f x- ifoldMap f (Magma i a) = f i a- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i (Magma i t b) where- itraverse f (MagmaAp x y) = MagmaAp <$> itraverse f x <*> itraverse f y- itraverse _ (MagmaPure x) = pure (MagmaPure x)- itraverse f (MagmaFmap xy x) = MagmaFmap xy <$> itraverse f x- itraverse f (Magma i a) = Magma i <$> f i a- {-# INLINE itraverse #-}--instance FunctorWithIndex i f => FunctorWithIndex [i] (Free f) where- imap f (Pure a) = Pure $ f [] a- imap f (Free s) = Free $ imap (\i -> imap (f . (:) i)) s- {-# INLINE imap #-}--instance FoldableWithIndex i f => FoldableWithIndex [i] (Free f) where- ifoldMap f (Pure a) = f [] a- ifoldMap f (Free s) = ifoldMap (\i -> ifoldMap (f . (:) i)) s- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i f => TraversableWithIndex [i] (Free f) where- itraverse f (Pure a) = Pure <$> f [] a- itraverse f (Free s) = Free <$> itraverse (\i -> itraverse (f . (:) i)) s- {-# INLINE itraverse #-}--instance Ix i => FunctorWithIndex i (Array i) where- imap f arr = Array.listArray (Array.bounds arr) . fmap (uncurry f) $ Array.assocs arr- {-# INLINE imap #-}--instance Ix i => FoldableWithIndex i (Array i) where- ifoldMap f = foldMap (uncurry f) . Array.assocs- {-# INLINE ifoldMap #-}--instance Ix i => TraversableWithIndex i (Array i) where- itraverse f arr = Array.listArray (Array.bounds arr) <$> traverse (uncurry f) (Array.assocs arr)- {-# INLINE itraverse #-}--instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where- imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as- {-# INLINE imap #-}--instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where- ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where- itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as- {-# INLINE itraverse #-}--instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (Compose f g) where- imap f (Compose fg) = Compose $ imap (\k -> imap (f . (,) k)) fg- {-# INLINE imap #-}--instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (Compose f g) where- ifoldMap f (Compose fg) = ifoldMap (\k -> ifoldMap (f . (,) k)) fg- {-# INLINE ifoldMap #-}--instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (Compose f g) where- itraverse f (Compose fg) = Compose <$> itraverse (\k -> itraverse (f . (,) k)) fg- {-# INLINE itraverse #-}--instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Sum f g) where- imap q (InL fa) = InL (imap (q . Left) fa)- imap q (InR ga) = InR (imap (q . Right) ga)- {-# INLINE imap #-}--instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Sum f g) where- ifoldMap q (InL fa) = ifoldMap (q . Left) fa- ifoldMap q (InR ga) = ifoldMap (q . Right) ga- {-# INLINE ifoldMap #-}--instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Sum f g) where- itraverse q (InL fa) = InL <$> itraverse (q . Left) fa- itraverse q (InR ga) = InR <$> itraverse (q . Right) ga- {-# INLINE itraverse #-}--instance FunctorWithIndex i m => FunctorWithIndex i (IdentityT m) where- imap f (IdentityT m) = IdentityT $ imap f m- {-# INLINE imap #-}--instance FoldableWithIndex i m => FoldableWithIndex i (IdentityT m) where- ifoldMap f (IdentityT m) = ifoldMap f m- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i m => TraversableWithIndex i (IdentityT m) where- itraverse f (IdentityT m) = IdentityT <$> itraverse f m- {-# INLINE itraverse #-}--instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Product f g) where- imap f (Pair a b) = Pair (imap (f . Left) a) (imap (f . Right) b)- {-# INLINE imap #-}--instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Product f g) where- ifoldMap f (Pair a b) = ifoldMap (f . Left) a `mappend` ifoldMap (f . Right) b- {-# INLINE ifoldMap #-}--instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Product f g) where- itraverse f (Pair a b) = Pair <$> itraverse (f . Left) a <*> itraverse (f . Right) b- {-# INLINE itraverse #-}--instance FunctorWithIndex i m => FunctorWithIndex (e, i) (ReaderT e m) where- imap f (ReaderT m) = ReaderT $ \k -> imap (f . (,) k) (m k)- {-# INLINE imap #-}--instance FunctorWithIndex i w => FunctorWithIndex (s, i) (TracedT s w) where- imap f (TracedT w) = TracedT $ imap (\k' g k -> f (k, k') (g k)) w- {-# INLINE imap #-}--instance FunctorWithIndex [Int] Tree where- imap f (Node a as) = Node (f [] a) $ imap (\i -> imap (f . (:) i)) as- {-# INLINE imap #-}--instance FoldableWithIndex [Int] Tree where- ifoldMap f (Node a as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as- {-# INLINE ifoldMap #-}--instance TraversableWithIndex [Int] Tree where- itraverse f (Node a as) = Node <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as- {-# INLINE itraverse #-}--instance FunctorWithIndex Void Proxy where- imap _ Proxy = Proxy- {-# INLINE imap #-}--instance FoldableWithIndex Void Proxy where- ifoldMap _ _ = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex Void Proxy where- itraverse _ _ = pure Proxy- {-# INLINE itraverse #-}--instance FunctorWithIndex () (Tagged a) where- imap f (Tagged a) = Tagged (f () a)- {-# INLINE imap #-}--instance FoldableWithIndex () (Tagged a) where- ifoldMap f (Tagged a) = f () a- {-# INLINE ifoldMap #-}--instance TraversableWithIndex () (Tagged a) where- itraverse f (Tagged a) = Tagged <$> f () a- {-# INLINE itraverse #-}--instance FunctorWithIndex Void V1 where- imap _ v = v `seq` undefined- {-# INLINE imap #-}--instance FoldableWithIndex Void V1 where- ifoldMap _ v = v `seq` undefined--instance TraversableWithIndex Void V1 where- itraverse _ v = v `seq` undefined--instance FunctorWithIndex Void U1 where- imap _ U1 = U1- {-# INLINE imap #-}--instance FoldableWithIndex Void U1 where- ifoldMap _ _ = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex Void U1 where- itraverse _ U1 = pure U1- {-# INLINE itraverse #-}--instance FunctorWithIndex () Par1 where- imap f = fmap (f ())- {-# INLINE imap #-}--instance FoldableWithIndex () Par1 where- ifoldMap f (Par1 a) = f () a- {-# INLINE ifoldMap #-}--instance TraversableWithIndex () Par1 where- itraverse f (Par1 a) = Par1 <$> f () a- {-# INLINE itraverse #-}--instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (f :.: g) where- imap q (Comp1 fga) = Comp1 (imap (\k -> imap (q . (,) k)) fga)- {-# INLINE imap #-}--instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (f :.: g) where- ifoldMap q (Comp1 fga) = ifoldMap (\k -> ifoldMap (q . (,) k)) fga- {-# INLINE ifoldMap #-}--instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (f :.: g) where- itraverse q (Comp1 fga) = Comp1 <$> itraverse (\k -> itraverse (q . (,) k)) fga- {-# INLINE itraverse #-}--instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :*: g) where- imap q (fa :*: ga) = imap (q . Left) fa :*: imap (q . Right) ga- {-# INLINE imap #-}--instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :*: g) where- ifoldMap q (fa :*: ga) = ifoldMap (q . Left) fa `mappend` ifoldMap (q . Right) ga- {-# INLINE ifoldMap #-}--instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :*: g) where- itraverse q (fa :*: ga) = (:*:) <$> itraverse (q . Left) fa <*> itraverse (q . Right) ga- {-# INLINE itraverse #-}--instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :+: g) where- imap q (L1 fa) = L1 (imap (q . Left) fa)- imap q (R1 ga) = R1 (imap (q . Right) ga)- {-# INLINE imap #-}--instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :+: g) where- ifoldMap q (L1 fa) = ifoldMap (q . Left) fa- ifoldMap q (R1 ga) = ifoldMap (q . Right) ga- {-# INLINE ifoldMap #-}--instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :+: g) where- itraverse q (L1 fa) = L1 <$> itraverse (q . Left) fa- itraverse q (R1 ga) = R1 <$> itraverse (q . Right) ga- {-# INLINE itraverse #-}--instance FunctorWithIndex i f => FunctorWithIndex i (Rec1 f) where- imap q (Rec1 f) = Rec1 (imap q f)- {-# INLINE imap #-}--instance FoldableWithIndex i f => FoldableWithIndex i (Rec1 f) where- ifoldMap q (Rec1 f) = ifoldMap q f- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i f => TraversableWithIndex i (Rec1 f) where- itraverse q (Rec1 f) = Rec1 <$> itraverse q f- {-# INLINE itraverse #-}--instance FunctorWithIndex Void (K1 i c) where- imap _ (K1 c) = K1 c- {-# INLINE imap #-}--instance FoldableWithIndex Void (K1 i c) where- ifoldMap _ _ = mempty- {-# INLINE ifoldMap #-}--instance TraversableWithIndex Void (K1 i c) where- itraverse _ (K1 a) = pure (K1 a)- {-# INLINE itraverse #-}------------------------------------------------------------------------------------ Misc.--------------------------------------------------------------------------------+{-# RULES+"itraversed -> mapSeq" itraversed = sets fmap :: ASetter (Seq a) (Seq b) a b;+"itraversed -> imapSeq" itraversed = isets Seq.mapWithIndex :: AnIndexedSetter Int (Seq a) (Seq b) a b;+"itraversed -> foldrSeq" itraversed = foldring foldr :: Getting (Endo r) (Seq a) a;+"itraversed -> ifoldrSeq" itraversed = ifoldring Seq.foldrWithIndex :: IndexedGetting Int (Endo r) (Seq a) a;+ #-} -skip :: a -> ()-skip _ = ()-{-# INLINE skip #-}+{-# RULES+"itraversed -> mapVector" itraversed = sets Vector.map :: ASetter (Vector a) (Vector b) a b;+"itraversed -> imapVector" itraversed = isets Vector.imap :: AnIndexedSetter Int (Vector a) (Vector b) a b;+"itraversed -> foldrVector" itraversed = foldring Vector.foldr :: Getting (Endo r) (Vector a) a;+"itraversed -> ifoldrVector" itraversed = ifoldring Vector.ifoldr :: IndexedGetting Int (Endo r) (Vector a) a;+ #-} ------------------------------------------------------------------------------- -- Indexed Folds with Reified Monoid
src/Control/Lens/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal@@ -41,7 +40,3 @@ import Control.Lens.Internal.Review import Control.Lens.Internal.Setter import Control.Lens.Internal.Zoom--#ifdef HLINT-{-# ANN module "HLint: ignore Use import/export shortcut" #-}-#endif
src/Control/Lens/Internal/Bazaar.hs view
@@ -3,9 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-}-#endif #if __GLASGOW_HASKELL__ >= 711 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif@@ -148,9 +146,7 @@ -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! newtype BazaarT p (g :: * -> *) a b t = BazaarT { runBazaarT :: forall f. Applicative f => p a (f b) -> f t }-#if __GLASGOW_HASKELL__ >= 707 type role BazaarT representational nominal nominal nominal nominal-#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. --@@ -326,9 +322,7 @@ -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! newtype BazaarT1 p (g :: * -> *) a b t = BazaarT1 { runBazaarT1 :: forall f. Apply f => p a (f b) -> f t }-#if __GLASGOW_HASKELL__ >= 707 type role BazaarT1 representational nominal nominal nominal nominal-#endif -- | This alias is helpful when it comes to reducing repetition in type signatures. --
src/Control/Lens/Internal/ByteString.hs view
@@ -23,10 +23,8 @@ -- Haskell Platforms and to improve constant and asymptotic factors in our performance. ---------------------------------------------------------------------------- module Control.Lens.Internal.ByteString- ( unpackStrict, traversedStrictTree- , unpackStrict8, traversedStrictTree8- , unpackLazy, traversedLazy- , unpackLazy8, traversedLazy8+ ( traversedStrictTree, traversedStrictTree8+ , traversedLazy, traversedLazy8 ) where import Prelude ()@@ -54,9 +52,6 @@ #else import Foreign.ForeignPtr.Safe #endif-#if !MIN_VERSION_bytestring(0,10,4)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-#endif import GHC.Base (unsafeChr) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) import GHC.IO (unsafeDupablePerformIO)@@ -128,16 +123,11 @@ ifoldrB8 f z xs = B8.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrB8 #-} --- | Unpack a lazy 'Bytestring'-unpackLazy :: BL.ByteString -> [Word8]-unpackLazy = BL.unpack-{-# INLINE unpackLazy #-}- -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' traversedLazy :: IndexedTraversal' Int64 BL.ByteString Word8-traversedLazy pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0+traversedLazy pafb = \lbs -> BL.foldrChunks go (\_ -> pure BL.empty) lbs 0 where- go c fcs acc = BL.append . fromStrict+ go c fcs acc = BL.append . BL.fromStrict <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree pafb c <*> fcs acc' where@@ -164,16 +154,11 @@ ifoldrBL f z xs = BL.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 {-# INLINE ifoldrBL #-} --- | Unpack a lazy 'BL.ByteString' pretending the bytes are chars.-unpackLazy8 :: BL.ByteString -> String-unpackLazy8 = BL8.unpack-{-# INLINE unpackLazy8 #-}- -- | An 'IndexedTraversal' of the individual bytes in a lazy 'BL.ByteString' pretending the bytes are chars. traversedLazy8 :: IndexedTraversal' Int64 BL.ByteString Char-traversedLazy8 pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0+traversedLazy8 pafb = \lbs -> BL.foldrChunks go (\_ -> pure BL.empty) lbs 0 where- go c fcs acc = BL.append . fromStrict+ go c fcs acc = BL.append . BL.fromStrict <$> reindexed (\x -> acc + fromIntegral x :: Int64) traversedStrictTree8 pafb c <*> fcs acc' where@@ -204,22 +189,6 @@ -- ByteString guts ------------------------------------------------------------------------------ -fromStrict :: B.ByteString -> BL.ByteString-#if MIN_VERSION_bytestring(0,10,0)-fromStrict = BL.fromStrict-#else-fromStrict = \x -> BL.fromChunks [x]-#endif-{-# INLINE fromStrict #-}--foldrChunks :: (B.ByteString -> r -> r) -> r -> BL.ByteString -> r-#if MIN_VERSION_bytestring(0,10,0)-foldrChunks = BL.foldrChunks-#else-foldrChunks f z b = foldr f z (BL.toChunks b)-#endif-{-# INLINE foldrChunks #-}- -- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. w2c :: Word8 -> Char w2c = unsafeChr . fromIntegral@@ -232,43 +201,6 @@ c2w = fromIntegral . ord {-# INLINE c2w #-} --- | Unpack a strict 'B.Bytestring'-unpackStrict :: B.ByteString -> [Word8]-#if MIN_VERSION_bytestring(0,10,4)-unpackStrict = B.unpack-#else-unpackStrict (BI.PS fp off len) =- let p = unsafeForeignPtrToPtr fp- in go (p `plusPtr` off) (p `plusPtr` (off+len))- where- go !p !q | p == q = []- | otherwise = let !x = BI.inlinePerformIO $ do- x' <- peek p- touchForeignPtr fp- return x'- in x : go (p `plusPtr` 1) q-#endif-{-# INLINE unpackStrict #-}---- | Unpack a strict 'B.Bytestring', pretending the bytes are chars.-unpackStrict8 :: B.ByteString -> String-#if MIN_VERSION_bytestring(0,10,4)-unpackStrict8 = B8.unpack-#else-unpackStrict8 (BI.PS fp off len) =- let p = unsafeForeignPtrToPtr fp- in go (p `plusPtr` off) (p `plusPtr` (off+len))- where- go !p !q | p == q = []- | otherwise = let !x = BI.inlinePerformIO $ do- x' <- peek p- touchForeignPtr fp- return x'- in w2c x : go (p `plusPtr` 1) q-#endif-{-# INLINE unpackStrict8 #-}-- -- | A way of creating ByteStrings outside the IO monad. The @Int@ -- argument gives the final size of the ByteString. Unlike -- 'createAndTrim' the ByteString is not reallocated if the final size@@ -282,5 +214,9 @@ create l f = do fp <- mallocPlainForeignPtrBytes l withForeignPtr fp $ \p -> f p+#if MIN_VERSION_bytestring(0,11,0)+ return $! BI.BS fp l+#else return $! BI.PS fp 0 l+#endif {-# INLINE create #-}
src/Control/Lens/Internal/Coerce.hs view
@@ -1,13 +1,7 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708-#define USE_COERCE {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-#else-{-# LANGUAGE Unsafe #-}-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2016 Edward Kmett and Eric Mertens@@ -16,9 +10,8 @@ -- Stability : experimental -- Portability : non-portable ----- This module provides a shim around 'coerce' that defaults to 'unsafeCoerce'--- on GHC < 7.8. It also exposes a type-restricted version of '(#.)' that--- works around a bizarre GHC 7.10–specific bug.+-- This module provides a shim around 'coerce'.+-- We need to work around a GHC 7.8-specific 'Coercible' solver bug(s). ----------------------------------------------------------------------------- module Control.Lens.Internal.Coerce ( coerce@@ -27,30 +20,16 @@ ) where import Data.Profunctor.Unsafe--#ifdef USE_COERCE- import Data.Coerce coerce' :: forall a b. Coercible a b => b -> a+#if __GLASGOW_HASKELL__ <710 coerce' = coerce (id :: a -> a)-{-# INLINE coerce' #-}--(#..) :: (Profunctor p, Coercible c b) => (b -> c) -> p a b -> p a c-(#..) = (#.)-{-# INLINE (#..) #-}- #else--import Unsafe.Coerce--coerce, coerce' :: a -> b-coerce = unsafeCoerce-coerce' = unsafeCoerce-{-# INLINE coerce #-}+coerce' = coerce+#endif {-# INLINE coerce' #-} -(#..) :: Profunctor p => (b -> c) -> p a b -> p a c+(#..) :: (Profunctor p, Coercible c b) => (b -> c) -> p a b -> p a c (#..) = (#.) {-# INLINE (#..) #-}-#endif
src/Control/Lens/Internal/Context.hs view
@@ -1,12 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-}-#endif ----------------------------------------------------------------------------- -- |@@ -63,9 +60,8 @@ -- "Parameterized Notions of Computation" <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 @@ -285,11 +281,9 @@ -- 'Control.Lens.Getter.Getter'. newtype PretextT p (g :: * -> *) a b t = PretextT { runPretextT :: forall f. Functor f => p a (f b) -> f t } -#if __GLASGOW_HASKELL__ >= 707 -- really we want PretextT p g a b t to permit the last 3 arguments to be representational iff p and f accept representational arguments -- but that isn't currently an option in GHC type role PretextT representational nominal nominal nominal nominal-#endif -- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@ type PretextT' p g a = PretextT p g a a
src/Control/Lens/Internal/Deque.hs view
@@ -40,16 +40,19 @@ import Data.Functor.Plus import Data.Functor.Reverse +-- $setup+-- >>> import Control.Applicative (empty)+ -- | A Banker's deque based on Chris Okasaki's \"Purely Functional Data Structures\" data Deque a = BD !Int [a] !Int [a] deriving Show -- | /O(1)/. Determine if a 'Deque' is 'empty'. ----- >>> null empty+-- >>> Control.Lens.Internal.Deque.null empty -- True ----- >>> null (singleton 1)+-- >>> Control.Lens.Internal.Deque.null (singleton 1) -- False null :: Deque a -> Bool null (BD lf _ lr _) = lf + lr == 0
src/Control/Lens/Internal/Exception.hs view
@@ -5,12 +5,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-}-#endif #include "lens-common.h" @@ -40,11 +37,6 @@ import Data.Reflection import Data.Typeable --- This is needed because ghc 7.8-rc2 has Typeable1 as a type alias.-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-#define Typeable1 Typeable-#endif- ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------@@ -138,13 +130,13 @@ instance Handleable SomeException IO Exception.Handler where handler = handlerIO -instance Typeable1 m => Handleable SomeException m (Catch.Handler m) where+instance Typeable m => Handleable SomeException m (Catch.Handler m) where handler = handlerCatchIO handlerIO :: forall a r. Typeable a => Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r handlerIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a) -handlerCatchIO :: forall m a r. (Typeable a, Typeable1 m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r+handlerCatchIO :: forall m a r. (Typeable a, Typeable m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r handlerCatchIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Catch.Handler (\(Handling a :: Handling a s m) -> f a) ------------------------------------------------------------------------------@@ -167,26 +159,10 @@ -- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does. newtype Handling a s (m :: * -> *) = Handling a-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 deriving Typeable type role Handling representational nominal nominal-#else--- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap.--- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep.-instance (Typeable a, Typeable s, Typeable1 m) => Typeable (Handling a s m) where- typeOf _ = mkTyConApp handlingTyCon- [ typeOf (undefined :: a)- , typeOf (undefined :: s)- , typeOf1 (undefined :: m a)- ]- {-# INLINE typeOf #-} -handlingTyCon :: TyCon-handlingTyCon = mkTyCon3 "lens" "Control.Lens.Internal.Exception" "Handling"-{-# NOINLINE handlingTyCon #-}-#endif- -- The @Handling@ wrapper is uninteresting, and should never be thrown, so you won't get much benefit here. instance Show (Handling a s m) where showsPrec d _ = showParen (d > 10) $ showString "Handling ..."@@ -194,11 +170,7 @@ instance ( Reifies s (SomeException -> Maybe a) , Typeable a, Typeable s-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 , Typeable m-#else- , Typeable1 m-#endif ) => Exception (Handling a (s :: *) m) where toException _ = SomeException HandlingException
src/Control/Lens/Internal/FieldTH.hs view
@@ -48,6 +48,7 @@ import Language.Haskell.TH.Lens import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D+import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Data.Maybe (isJust,maybeToList) import Data.List (nub, findIndices) import Data.Either (partitionEithers)@@ -84,7 +85,7 @@ let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons let defCons = over normFieldLabels (expandName allFields) fieldCons allDefs = setOf (normFieldLabels . folded) defCons- T.sequenceA (fromSet (buildScaffold rules s defCons) allDefs)+ T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of@@ -94,9 +95,9 @@ return (concat decss) where- tyName = D.datatypeName info- s = D.datatypeType info- cons = D.datatypeCons info+ tyName = D.datatypeName info+ s = datatypeTypeKinded info+ cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b@@ -241,7 +242,7 @@ let s' = applyTypeSubst subA s -- compute possible type changes- sub <- T.sequenceA (fromSet (newName . nameBase) unfixedTypeVars)+ sub <- T.sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars) let (t,b) = over both (substTypeVars sub) (s',a) return (s',t,a,b)@@ -319,12 +320,13 @@ let ss = map (stabToS . view (_2 . _2)) defs (sub,s') <- unifyTypes (s : ss) c <- newName "c"- let vars = toListOf typeVars s'+ let vars = D.freeVariablesWellScoped [s']+ varNames = map D.tvName vars fd | null vars = []- | otherwise = [FunDep [c] vars]+ | otherwise = [FunDep [c] varNames] - classD (cxt[]) className (map PlainTV (c:vars)) fd+ classD (cxt[]) className (D.plainTV c:vars) fd $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s'])) : concat [ [sigD defName (return ty)@@ -333,7 +335,7 @@ inlinePragma defName | (TopName defName, (_, stab, _)) <- defs , let body = appsE [varE composeValName, varE methodName, varE defName]- , let ty = quantifyType' (Set.fromList (c:vars))+ , let ty = quantifyType' (Set.fromList (c:varNames)) (stabToContext stab) $ stabToOptic stab `conAppsT` [VarT c, applyTypeSubst sub (stabToA stab)]@@ -355,8 +357,8 @@ : map return (concat methodss) where- instanceHead = className `conAppsT` (s : map VarT vars)- vars = toListOf typeVars s+ instanceHead = className `conAppsT` (s : map tvbToType vars)+ vars = D.freeVariablesWellScoped [s] rules' = rules { _generateSigs = False , _generateClasses = False }@@ -367,7 +369,7 @@ makeFieldClass :: OpticStab -> Name -> Name -> DecQ makeFieldClass defType className methodName =- classD (cxt []) className [PlainTV s, PlainTV a] [FunDep [s] [a]]+ classD (cxt []) className [D.plainTV s, D.plainTV a] [FunDep [s] [a]] [sigD methodName (return methodType)] where methodType = quantifyType' (Set.fromList [s,a])@@ -398,9 +400,6 @@ #if !(MIN_VERSION_template_haskell(2,11,0)) _OpenTypeFamilyD = _FamilyD . _1 . _TypeFam #endif-#if !(MIN_VERSION_template_haskell(2,9,0))- _ClosedTypeFamilyD = ignored-#endif pickInstanceDec hasFamilies | hasFamilies = do@@ -557,18 +556,13 @@ -- | Perform a limited substitution on type variables. This is used -- when unifying rank-2 fields when trying to achieve a Getter or Fold.-limitedSubst :: Map Name Type -> TyVarBndr -> Q TyVarBndr-limitedSubst sub (PlainTV n)- | Just r <- Map.lookup n sub =- case r of- VarT m -> limitedSubst sub (PlainTV m)- _ -> fail "Unable to unify exotic higher-rank type"-limitedSubst sub (KindedTV n k)- | Just r <- Map.lookup n sub =+limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec+limitedSubst sub tv+ | Just r <- Map.lookup (D.tvName tv) sub = case r of- VarT m -> limitedSubst sub (KindedTV m k)+ VarT m -> limitedSubst sub (D.mapTVName (const m) tv) _ -> fail "Unable to unify exotic higher-rank type"-limitedSubst _ tv = return tv+ | otherwise = return tv -- | Apply a substitution to a type. This is used after unifying@@ -627,23 +621,3 @@ addFieldClassName :: Name -> HasFieldClasses () addFieldClassName n = modify $ Set.insert n----------------------------------------------------------------------------- Miscellaneous utility functions------------------------------------------------------------------------------ | Template Haskell wants type variables declared in a forall, so--- we find all free type variables in a given type and declare them.-quantifyType :: Cxt -> Type -> Type-quantifyType = quantifyType' Set.empty---- | This function works like 'quantifyType' except that it takes--- a list of variables to exclude from quantification.-quantifyType' :: Set Name -> Cxt -> Type -> Type-quantifyType' exclude c t = ForallT vs c t- where- vs = map PlainTV- $ filter (`Set.notMember` exclude)- $ nub -- stable order- $ toListOf typeVars t
src/Control/Lens/Internal/Fold.hs view
@@ -23,8 +23,6 @@ , Traversed(..) , TraversedF(..) , Sequenced(..)- , Max(..), getMax- , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost , ReifiedMonoid(..)@@ -42,10 +40,6 @@ import qualified Data.List.NonEmpty as NonEmpty -#ifdef HLINT-{-# ANN module "HLint: ignore Avoid lambda" #-}-#endif- ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------@@ -122,60 +116,6 @@ {-# INLINE mempty #-} Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) {-# INLINE mappend #-}----------------------------------------------------------------------------------- Min----------------------------------------------------------------------------------- | Used for 'Control.Lens.Fold.minimumOf'.-data Min a = NoMin | Min a--instance Ord a => Semigroup (Min a) where- NoMin <> m = m- m <> NoMin = m- Min a <> Min b = Min (min a b)- {-# INLINE (<>) #-}--instance Ord a => Monoid (Min a) where- mempty = NoMin- {-# INLINE mempty #-}- mappend NoMin m = m- mappend m NoMin = m- mappend (Min a) (Min b) = Min (min a b)- {-# INLINE mappend #-}---- | Obtain the minimum.-getMin :: Min a -> Maybe a-getMin NoMin = Nothing-getMin (Min a) = Just a-{-# INLINE getMin #-}----------------------------------------------------------------------------------- Max----------------------------------------------------------------------------------- | Used for 'Control.Lens.Fold.maximumOf'.-data Max a = NoMax | Max a--instance Ord a => Semigroup (Max a) where- NoMax <> m = m- m <> NoMax = m- Max a <> Max b = Max (max a b)- {-# INLINE (<>) #-}--instance Ord a => Monoid (Max a) where- mempty = NoMax- {-# INLINE mempty #-}- mappend NoMax m = m- mappend m NoMax = m- mappend (Max a) (Max b) = Max (max a b)- {-# INLINE mappend #-}---- | Obtain the maximum.-getMax :: Max a -> Maybe a-getMax NoMax = Nothing-getMax (Max a) = Just a-{-# INLINE getMax #-} ------------------------------------------------------------------------------ -- NonEmptyDList
src/Control/Lens/Internal/Indexed.hs view
@@ -5,10 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}--#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |@@ -52,14 +49,13 @@ import Data.Int import Data.Profunctor.Closed import Data.Profunctor.Rep-#ifndef SAFE import Control.Lens.Internal.Coerce-#endif -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens+-- >>> import Data.Semigroup (Semigroup (..)) -- ------------------------------------------------------------------------------ -- Conjoined@@ -154,12 +150,10 @@ {-# INLINE lmap #-} rmap bc iab = Indexed $ \i -> bc . runIndexed iab i {-# INLINE rmap #-}-#ifndef SAFE- ( .# ) ibc _ = coerce ibc- {-# INLINE ( .# ) #-}- ( #. ) _ = coerce'- {-# INLINE ( #. ) #-}-#endif+ (.#) ibc _ = coerce ibc+ {-# INLINE (.#) #-}+ (#.) _ = coerce'+ {-# INLINE (#.) #-} instance Closed (Indexed i) where closed (Indexed iab) = Indexed $ \i xa x -> iab i (xa x)
src/Control/Lens/Internal/Iso.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif@@ -18,21 +19,24 @@ ) where import Data.Profunctor-#ifndef SAFE import Data.Profunctor.Unsafe import Control.Lens.Internal.Coerce-#endif-import Data.ByteString as StrictB-import Data.ByteString.Lazy as LazyB-import Data.List.NonEmpty as NonEmpty-import Data.Text as StrictT-import Data.Text.Lazy as LazyT-import Data.Vector as Vector-import Data.Vector.Primitive as Prim-import Data.Vector.Storable as Storable-import Data.Vector.Unboxed as Unbox-import Data.Sequence as Seq +import qualified Data.ByteString as StrictB+import qualified Data.ByteString.Lazy as LazyB+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as StrictT+import qualified Data.Text.Lazy as LazyT+import qualified Data.Vector as Vector+import qualified Data.Vector.Primitive as Prim+import Data.Vector.Primitive (Prim)+import qualified Data.Vector.Storable as Storable+import qualified Data.Vector.Unboxed as Unbox+import Data.Vector.Unboxed (Unbox)+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+import Foreign.Storable (Storable)+ ------------------------------------------------------------------------------ -- Isomorphism: Exchange ------------------------------------------------------------------------------@@ -52,12 +56,9 @@ {-# INLINE lmap #-} rmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE rmap #-}-#ifndef SAFE- ( #. ) _ = coerce'- {-# INLINE ( #. ) #-}- ( .# ) p _ = coerce p- {-# INLINE ( .# ) #-}-#endif+ (#.) _ = coerce'+ {-# INLINE (#.) #-}+ (.#) p _ = coerce p ------------------------------------------------------------------------------ -- Reversible
src/Control/Lens/Internal/Level.hs view
@@ -30,6 +30,9 @@ import Control.Lens.Internal.Prelude import Data.Functor.Apply+import Data.Functor.WithIndex+import Data.Foldable.WithIndex+import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Levels@@ -85,6 +88,27 @@ go (One i a) = One i <$> f a go Zero = pure Zero {-# INLINE traverse #-}++instance FunctorWithIndex i (Level i) where+ imap f = go where+ go (Two n l r) = Two n (go l) (go r)+ go (One i a) = One i (f i a)+ go Zero = Zero+ {-# INLINE imap #-}++instance FoldableWithIndex i (Level i) where+ ifoldMap f = go where+ go (Two _ l r) = go l `mappend` go r+ go (One i a) = f i a+ go Zero = mempty+ {-# INLINE ifoldMap #-}++instance TraversableWithIndex i (Level i) where+ itraverse f = go where+ go (Two n l r) = Two n <$> go l <*> go r+ go (One i a) = One i <$> f i a+ go Zero = pure Zero+ {-# INLINE itraverse #-} ------------------------------------------------------------------------------ -- Generating Levels
src/Control/Lens/Internal/List.hs view
@@ -18,10 +18,6 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -#ifdef HLINT-{-# ANN module "HLint: ignore Redundant bracket" #-}-#endif- -- | Return the the subset of given ordinals within a given bound -- and in order of the first occurrence seen. --
src/Control/Lens/Internal/Magma.hs view
@@ -6,9 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Magma@@ -42,6 +40,9 @@ import Control.Lens.Internal.Indexed import Control.Lens.Internal.Prelude import Data.Functor.Apply+import Data.Functor.WithIndex+import Data.Foldable.WithIndex+import Data.Traversable.WithIndex ------------------------------------------------------------------------------ -- Magma@@ -55,10 +56,8 @@ MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a Magma :: i -> a -> Magma i b b a -#if __GLASGOW_HASKELL__ >= 707 -- note the 3rd argument infers as phantom, but that would be unsound type role Magma representational nominal nominal nominal-#endif instance Functor (Magma i t b) where fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y)@@ -78,6 +77,27 @@ traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x traverse f (Magma i a) = Magma i <$> f a +instance FunctorWithIndex i (Magma i t b) where+ imap f (MagmaAp x y) = MagmaAp (imap f x) (imap f y)+ imap _ (MagmaPure x) = MagmaPure x+ imap f (MagmaFmap xy x) = MagmaFmap xy (imap f x)+ imap f (Magma i a) = Magma i (f i a)+ {-# INLINE imap #-}++instance FoldableWithIndex i (Magma i t b) where+ ifoldMap f (MagmaAp x y) = ifoldMap f x `mappend` ifoldMap f y+ ifoldMap _ MagmaPure{} = mempty+ ifoldMap f (MagmaFmap _ x) = ifoldMap f x+ ifoldMap f (Magma i a) = f i a+ {-# INLINE ifoldMap #-}++instance TraversableWithIndex i (Magma i t b) where+ itraverse f (MagmaAp x y) = MagmaAp <$> itraverse f x <*> itraverse f y+ itraverse _ (MagmaPure x) = pure (MagmaPure x)+ itraverse f (MagmaFmap xy x) = MagmaFmap xy <$> itraverse f x+ itraverse f (Magma i a) = Magma i <$> f i a+ {-# INLINE itraverse #-}+ instance (Show i, Show a) => Show (Magma i t b a) where showsPrec d (MagmaAp x y) = showParen (d > 4) $ showsPrec 4 x . showString " <*> " . showsPrec 5 y@@ -210,9 +230,7 @@ -- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant', -- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma' data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a))-#if __GLASGOW_HASKELL__ >= 707 type role TakingWhile nominal nominal nominal nominal nominal-#endif -- | Generate a 'Magma' with leaves only while the predicate holds from left to right. runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a)
src/Control/Lens/Internal/Prelude.hs view
@@ -109,6 +109,10 @@ import Data.Tagged (Tagged (..)) import Data.Void (Void, absurd) +-- TraversableWithIndex instances for tagged, vector and unordered-containers+-- We import this here, so the instances propagate through all (most) of @lens@.+import Data.Functor.WithIndex.Instances ()+ -- $setup -- >>> import Control.Lens -- >>> import Control.Monad.State
src/Control/Lens/Internal/Prism.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Prism@@ -17,10 +17,7 @@ import Prelude () import Control.Lens.Internal.Prelude--#ifndef SAFE import Control.Lens.Internal.Coerce-#endif ------------------------------------------------------------------------------ -- Prism: Market@@ -45,12 +42,10 @@ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE rmap #-} -#ifndef SAFE- ( #. ) _ = coerce'- {-# INLINE ( #. ) #-}- ( .# ) p _ = coerce p- {-# INLINE ( .# ) #-}-#endif+ (#.) _ = coerce'+ {-# INLINE (#.) #-}+ (.#) p _ = coerce p+ {-# INLINE (.#) #-} instance Choice (Market a b) where left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
src/Control/Lens/Internal/PrismTH.hs view
@@ -23,21 +23,22 @@ ) where import Control.Applicative-import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal.TH import Control.Lens.Lens import Control.Lens.Setter import Control.Monad import Data.Char (isUpper)-import Data.List+import qualified Data.List as List import Data.Set.Lens import Data.Traversable import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D+import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Lens import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Set (Set) import Prelude -- | Generate a 'Prism' for each constructor of a data type.@@ -136,7 +137,7 @@ let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info- makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls+ makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given 'Dec'@@ -146,7 +147,7 @@ let cls | normal = Nothing | otherwise = Just (D.datatypeName info) cons = D.datatypeCons info- makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls+ makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons) cls -- | Generate prisms for the given type, normalized constructors, and@@ -165,7 +166,7 @@ stab <- computeOpticType t cons con let n = prismName conName sequenceA- ( [ sigD n (close (stabToType stab))+ ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab))) , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] ] ++ inlinePragma n@@ -196,24 +197,22 @@ stabSimple :: Stab -> Bool stabSimple (Stab _ _ s t a b) = s == t && a == b -stabToType :: Stab -> Type-stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $- case ty of- PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b]- | otherwise -> prismTypeName `conAppsT` [s,t,a,b]- ReviewType -> reviewTypeName `conAppsT` [t,b]-+stabToType :: Set Name -> Stab -> Type+stabToType clsTVBNames stab@(Stab cx ty s t a b) =+ quantifyType' clsTVBNames cx stabTy where- vs = map PlainTV- $ nub -- stable order- $ toListOf typeVars cx+ stabTy =+ case ty of+ PrismType | stabSimple stab -> prism'TypeName `conAppsT` [t,b]+ | otherwise -> prismTypeName `conAppsT` [s,t,a,b]+ ReviewType -> reviewTypeName `conAppsT` [t,b] stabType :: Stab -> OpticType stabType (Stab _ o _ _ _ _) = o computeOpticType :: Type -> [NCon] -> NCon -> Q Stab computeOpticType t cons con =- do let cons' = delete con cons+ do let cons' = List.delete con cons if null (_nconVars con) then computePrismType t (view nconCxt con) cons' con else computeReviewType t (view nconCxt con) (view nconTypes con)@@ -235,7 +234,7 @@ computePrismType t cx cons con = do let ts = view nconTypes con unbound = setOf typeVars t Set.\\ setOf typeVars cons- sub <- sequenceA (fromSet (newName . nameBase) unbound)+ sub <- sequenceA (Map.fromSet (newName . nameBase) unbound) b <- toTupleT (map return ts) a <- toTupleT (map return (substTypeVars sub ts)) let s = substTypeVars sub t@@ -244,18 +243,16 @@ computeIsoType :: Type -> [Type] -> TypeQ computeIsoType t' fields =- do sub <- sequenceA (fromSet (newName . nameBase) (setOf typeVars t'))+ do sub <- sequenceA (Map.fromSet (newName . nameBase) (setOf typeVars t')) let t = return t' s = return (substTypeVars sub t') b = toTupleT (map return fields) a = toTupleT (map return (substTypeVars sub fields)) -#ifndef HLINT ty | Map.null sub = appsT (conT iso'TypeName) [t,b] | otherwise = appsT (conT isoTypeName) [s,t,a,b]-#endif - close =<< ty+ quantifyType [] <$> ty @@ -416,11 +413,9 @@ DecQ makeClassyPrismClass t className methodName cons = do r <- newName "r"-#ifndef HLINT let methodType = appsT (conT prism'TypeName) [varT r,return t]-#endif- methodss <- traverse (mkMethod (VarT r)) cons'- classD (cxt[]) className (map PlainTV (r : vs)) (fds r)+ methodss <- traverse (mkMethod r) cons'+ classD (cxt[]) className (D.plainTV r : vs) (fds r) ( sigD methodName methodType : map return (concat methodss) )@@ -428,19 +423,21 @@ where mkMethod r con = do Stab cx o _ _ _ b <- computeOpticType t cons con- let stab' = Stab cx o r r b b+ let rTy = VarT r+ stab' = Stab cx o rTy rTy b b defName = view nconName con body = appsE [varE composeValName, varE methodName, varE defName] sequenceA- [ sigD defName (return (stabToType stab'))+ [ sigD defName (return (stabToType (Set.fromList (r:vNames)) stab')) , valD (varP defName) (normalB body) [] ] cons' = map (over nconName prismName) cons- vs = Set.toList (setOf typeVars t)+ vs = D.freeVariablesWellScoped [t]+ vNames = map D.tvName vs fds r | null vs = []- | otherwise = [FunDep [r] vs]+ | otherwise = [FunDep [r] vNames] @@ -456,8 +453,8 @@ [NCon] {- Constructors -} -> DecQ makeClassyPrismInstance s className methodName cons =- do let vs = Set.toList (setOf typeVars s)- cls = className `conAppsT` (s : map VarT vs)+ do let vs = D.freeVariablesWellScoped [s]+ cls = className `conAppsT` (s : map tvbToType vs) instanceD (cxt[]) (return cls) ( valD (varP methodName)@@ -488,7 +485,7 @@ instance HasTypeVars NCon where typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z- where s' = foldl' (flip Set.insert) s vars+ where s' = List.foldl' (flip Set.insert) s vars nconName :: Lens' NCon Name nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x))@@ -540,9 +537,3 @@ prefix :: Char -> String -> String prefix char str | sameNameAsCon = char:char:str | otherwise = char:str---- | Quantify all the free variables in a type.-close :: Type -> TypeQ-close t = forallT (map PlainTV (Set.toList vs)) (cxt[]) (return t)- where- vs = setOf typeVars t
+ src/Control/Lens/Internal/Profunctor.hs view
@@ -0,0 +1,17 @@+module Control.Lens.Internal.Profunctor + ( WrappedPafb (..)+ ) where++import Prelude ()+import Control.Lens.Internal.Prelude++newtype WrappedPafb f p a b = WrapPafb { unwrapPafb :: p a (f b) }++instance (Functor f, Profunctor p) => Profunctor (WrappedPafb f p) where+ dimap f g (WrapPafb p) = WrapPafb $ dimap f (fmap g) p++instance (Applicative f, Choice p) => Choice (WrappedPafb f p) where+ left' (WrapPafb p) = WrapPafb $ rmap sequenceL $ left' p+ where+ sequenceL (Left a) = fmap Left a+ sequenceL (Right a) = pure $ Right a
src/Control/Lens/Internal/Setter.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |
src/Control/Lens/Internal/TH.hs view
@@ -22,10 +22,12 @@ module Control.Lens.Internal.TH where import Data.Functor.Contravariant+import qualified Data.Set as Set+import Data.Set (Set) import Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D+import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Syntax-import qualified Data.Map as Map-import qualified Data.Set as Set #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_lens (version)@@ -58,19 +60,6 @@ conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) ---- | Return 'Name' contained in a 'TyVarBndr'.-bndrName :: TyVarBndr -> Name-bndrName (PlainTV n ) = n-bndrName (KindedTV n _) = n--fromSet :: (k -> v) -> Set.Set k -> Map.Map k v-#if MIN_VERSION_containers(0,5,0)-fromSet = Map.fromSet-#else-fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ]-#endif- -- | Generate many new names from a given base name. newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] newNames base n = sequence [ newName (base++show i) | i <- [1..n] ]@@ -103,6 +92,80 @@ #endif go acc ty = (ty, acc) +-- Construct a 'Type' using the datatype's type constructor and type+-- parameters. Unlike 'D.datatypeType', kind signatures are preserved to+-- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more+-- details on this.)+datatypeTypeKinded :: D.DatatypeInfo -> Type+datatypeTypeKinded di+ = foldl AppT (ConT (D.datatypeName di))+ $ dropSigsIfNonDataFam+ $ D.datatypeInstTypes di+ where+ {-+ In an effort to prevent users from having to enable KindSignatures every+ time that they use lens' TH functionality, we strip off reified kind+ annotations from when:++ 1. The kind of a type does not contain any kind variables. If it *does*+ contain kind variables, we want to preserve them so that we can generate+ type signatures that preserve the dependency order of kind and type+ variables. (The data types in test/T917.hs contain examples where this+ is important.) This will require enabling `PolyKinds`, but since+ `PolyKinds` implies `KindSignatures`, we can at least accomplish two+ things at once.+ 2. The data type is not an instance of a data family. We make an exception+ for data family instances, since the presence or absence of a kind+ annotation can be the difference between typechecking or not.+ (See T917DataFam in tests/T917.hs for an example.) Moreover, the+ `TypeFamilies` extension implies `KindSignatures`.+ -}+ dropSigsIfNonDataFam :: [Type] -> [Type]+ dropSigsIfNonDataFam+ | isDataFamily (D.datatypeVariant di) = id+ | otherwise = map dropSig++ dropSig :: Type -> Type+ dropSig (SigT t k) | null (D.freeVariables k) = t+ dropSig t = t++-- | Template Haskell wants type variables declared in a forall, so+-- we find all free type variables in a given type and declare them.+quantifyType :: Cxt -> Type -> Type+quantifyType = quantifyType' Set.empty++-- | This function works like 'quantifyType' except that it takes+-- a list of variables to exclude from quantification.+quantifyType' :: Set Name -> Cxt -> Type -> Type+quantifyType' exclude c t = ForallT vs c t+ where+ vs = filter (\tvb -> D.tvName tvb `Set.notMember` exclude)+ $ D.changeTVFlags D.SpecifiedSpec+ $ D.freeVariablesWellScoped (t:concatMap predTypes c) -- stable order++ predTypes :: Pred -> [Type]+#if MIN_VERSION_template_haskell(2,10,0)+ predTypes p = [p]+#else+ predTypes (ClassP _ ts) = ts+ predTypes (EqualP t1 t2) = [t1, t2]+#endif++-- | Convert a 'TyVarBndr' into its corresponding 'Type'.+tvbToType :: D.TyVarBndr_ flag -> Type+tvbToType = D.elimTV VarT (SigT . VarT)++-- | Peel off a kind signature from a Type (if it has one).+unSigT :: Type -> Type+unSigT (SigT t _) = t+unSigT t = t++isDataFamily :: D.DatatypeVariant -> Bool+isDataFamily D.Datatype = False+isDataFamily D.Newtype = False+isDataFamily D.DataInstance = True+isDataFamily D.NewtypeInstance = True+ ------------------------------------------------------------------------ -- Manually quoted names ------------------------------------------------------------------------@@ -219,26 +282,4 @@ ------------------------------------------------------------------------ inlinePragma :: Name -> [DecQ]--#ifdef INLINING--#if MIN_VERSION_template_haskell(2,8,0)--# ifdef OLD_INLINE_PRAGMAS--- 7.6rc1?-inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase Inline False)]-# else--- 7.7.20120830 inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases]-# endif--#else--- GHC <7.6, TH <2.8.0-inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]-#endif--#else--inlinePragma _ = []--#endif
− src/Control/Lens/Internal/Typeable.hs
@@ -1,24 +0,0 @@-{-# language CPP #-}-{-# language TypeOperators #-}-{-# language ScopedTypeVariables #-}-module Control.Lens.Internal.Typeable (- eqT- , typeRep- ) where-#if MIN_VERSION_base (4,7,0)-import Data.Typeable (eqT, typeRep)--#else--import Data.Type.Equality-import Data.Typeable (Typeable, TypeRep, gcast, typeOf)---- | Extract a witness of equality of two types-eqT :: (Typeable a, Typeable b) => Maybe (a :~: b)-eqT = gcast Refl---- | Takes a value of type @a@ and returns a concrete representation of that type.-typeRep :: forall proxy a . Typeable a => proxy a -> TypeRep-typeRep _ = typeOf (undefined :: a)--#endif
src/Control/Lens/Internal/Zoom.hs view
@@ -33,7 +33,7 @@ import Prelude () import Control.Lens.Internal.Prelude-import Control.Monad.Reader as Reader+import Control.Monad import Control.Monad.Trans.Free import Data.Functor.Bind
src/Control/Lens/Iso.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -51,16 +50,15 @@ , enum , curried, uncurried , flipped- , Swapped(..)+ , swapped #if __GLASGOW_HASKELL__ >= 710 , pattern Swapped #endif- , Strict(..)+ , strict, lazy #if __GLASGOW_HASKELL__ >= 710 , pattern Strict , pattern Lazy #endif- , lazy , Reversing(..) , reversed #if __GLASGOW_HASKELL__ >= 710@@ -85,44 +83,25 @@ , bimapping , firsting , seconding-#if __GLASGOW_HASKELL__ >= 708 -- * Coercions , coerced-#endif ) where import Control.Lens.Equality (simple) import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Internal.Context-import Control.Lens.Internal.Coerce import Control.Lens.Internal.Indexed import Control.Lens.Internal.Iso as Iso import Control.Lens.Internal.Magma import Control.Lens.Prism import Control.Lens.Review import Control.Lens.Type-import Control.Monad.State.Lazy as Lazy-import Control.Monad.State.Strict as Strict-import Control.Monad.Writer.Lazy as Lazy hiding (Product, Sum)-import Control.Monad.Writer.Strict as Strict hiding (Product, Sum)-import Control.Monad.RWS.Lazy as Lazy hiding (Product, Sum)-import Control.Monad.RWS.Strict as Strict hiding (Product, Sum)-import Control.Monad.ST.Lazy as Lazy-import Control.Monad.ST as Strict import Data.Bifunctor-import Data.Bifunctor.Biff-import Data.Bifunctor.Flip-import Data.Bifunctor.Product-import Data.Bifunctor.Sum-import Data.Bifunctor.Tannen-import Data.ByteString as StrictB hiding (reverse)-import Data.ByteString.Lazy as LazyB hiding (reverse)+import Data.Bifunctor.Swap (Swap (..)) import Data.Functor.Identity-import Data.Text as StrictT hiding (reverse)-import Data.Text.Lazy as LazyT hiding (reverse)-import Data.Tuple (swap)+import Data.Strict.Classes (Strict (..)) import Data.Maybe import Data.Profunctor import Data.Profunctor.Unsafe@@ -131,12 +110,10 @@ import Data.Functor #endif -#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce (Coercible)+import Data.Coerce #if __GLASGOW_HASKELL__ < 710 import Data.Type.Coercion #endif-#endif #if __GLASGOW_HASKELL__ >= 710 import qualified GHC.Exts as Exts@@ -146,14 +123,10 @@ import GHC.Exts (TYPE) #endif -#ifdef HLINT-{-# ANN module "HLint: ignore Use on" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens--- >>> import Data.Map as Map+-- >>> import qualified Data.Map as Map -- >>> import Data.Foldable -- >>> import Data.Monoid @@ -190,7 +163,7 @@ -- 'from' ('from' l) ≡ l -- @ from :: AnIso s t a b -> Iso b a t s-from l = withIso l $ flip iso+from l = withIso l $ \sa bt -> iso bt sa {-# INLINE from #-} -- | Extract the two functions, one from @s -> a@ and@@ -212,7 +185,7 @@ -- -- See 'Control.Lens.Lens.cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this. cloneIso :: AnIso s t a b -> Iso s t a b-cloneIso k = withIso k iso+cloneIso k = withIso k $ \sa bt -> iso sa bt {-# INLINE cloneIso #-} -----------------------------------------------------------------------------@@ -352,7 +325,7 @@ -- and when have deleting the last entry from the nested 'Data.Map.Map' mean that we -- should delete its entry from the surrounding one: ----- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing+-- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing -- fromList [] -- -- It can also be used in reverse to exclude a given value:@@ -363,7 +336,7 @@ -- >>> non 0 # rem 10 5 -- Nothing non :: Eq a => a -> Iso' (Maybe a) a-non = non' . only+non a = non' $ only a {-# INLINE non #-} -- | @'non'' p@ generalizes @'non' (p # ())@ to take any unit 'Prism'@@ -373,7 +346,7 @@ -- >>> Map.singleton "hello" Map.empty & at "hello" . non' _Empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] ----- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing+-- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . non' _Empty . at "world" .~ Nothing -- fromList [] non' :: APrism' a () -> Iso' (Maybe a) a non' p = iso (fromMaybe def) go where@@ -389,7 +362,7 @@ -- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] ----- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing+-- >>> Map.fromList [("hello",Map.fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing -- fromList [] anon :: a -> (a -> Bool) -> Iso' (Maybe a) a anon a p = iso (fromMaybe a) go where@@ -436,81 +409,29 @@ flipped = iso flip flip {-# INLINE flipped #-} --- | This class provides for symmetric bifunctors.-class Bifunctor p => Swapped p where- -- |- -- @- -- 'swapped' '.' 'swapped' ≡ 'id'- -- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f- -- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g- -- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f- -- @- --- -- >>> (1,2)^.swapped- -- (2,1)- swapped :: Iso (p a b) (p c d) (p b a) (p d c)--instance Swapped (,) where- swapped = iso swap swap--instance Swapped Either where- swapped = iso (either Right Left) (either Right Left)--instance (Swapped f, Swapped g) => Swapped (Product f g) where- swapped = iso f f- where- f (Pair x y) = Pair (x ^. swapped) (y ^. swapped)--instance (Swapped p, Swapped q) => Swapped (Sum p q) where- swapped = iso f f- where- f (L2 x) = L2 (x ^. swapped)- f (R2 x) = R2 (x ^. swapped)--instance (Swapped p) => Swapped (Flip p) where- swapped = iso f f- where- f (Flip p) = Flip (p ^. swapped)--instance (f ~ g, Functor f, Swapped p) => Swapped (Biff p f g) where- swapped = iso f f- where- f (Biff p) = Biff (p ^. swapped)--instance (Functor f, Swapped p) => Swapped (Tannen f p) where- swapped = iso f f- where- f (Tannen x) = Tannen $ fmap (^. swapped) x--instance Swapped ((,,) x) where- swapped = iso f f- where- f (x,a,b) = (x,b,a)--instance Swapped ((,,,) x y) where- swapped = iso f f- where- f (x,y,a,b) = (x,y,b,a)--instance Swapped ((,,,,) x y z) where- swapped = iso f f- where- f (x,y,z,a,b) = (x,y,z,b,a)--instance Swapped ((,,,,,) x y z w) where- swapped = iso f f- where- f (x,y,z,w,a,b) = (x,y,z,w,b,a)--instance Swapped ((,,,,,,) x y z w v) where- swapped = iso f f- where- f (x,y,z,w,v,a,b) = (x,y,z,w,v,b,a)+-- |+-- @+-- 'swapped' '.' 'swapped' ≡ 'id'+-- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f+-- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g+-- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f+-- @+--+-- >>> (1,2)^.swapped+-- (2,1)+swapped :: Swap p => Iso (p a b) (p c d) (p b a) (p d c)+swapped = iso swap swap+{-# INLINE swapped #-} --- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure,--- such as 'StrictT.Text' or 'StrictB.ByteString'.-class Strict lazy strict | lazy -> strict, strict -> lazy where- strict :: Iso' lazy strict+-- | An 'Iso' between the lazy variant of a structure and its strict+-- counterpart.+--+-- @+-- 'strict' = 'from' 'lazy'+-- @+strict :: Strict lazy strict => Iso' lazy strict+strict = iso toStrict toLazy+{-# INLINE strict #-} #if __GLASGOW_HASKELL__ >= 710 pattern Strict a <- (view strict -> a) where@@ -526,34 +447,6 @@ Reversed a = review reversed a #endif -instance Strict LazyB.ByteString StrictB.ByteString where-#if MIN_VERSION_bytestring(0,10,0)- strict = iso LazyB.toStrict LazyB.fromStrict-#else- strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return)-#endif- {-# INLINE strict #-}--instance Strict LazyT.Text StrictT.Text where- strict = iso LazyT.toStrict LazyT.fromStrict- {-# INLINE strict #-}--instance Strict (Lazy.StateT s m a) (Strict.StateT s m a) where- strict = iso (Strict.StateT . Lazy.runStateT) (Lazy.StateT . Strict.runStateT)- {-# INLINE strict #-}--instance Strict (Lazy.WriterT w m a) (Strict.WriterT w m a) where- strict = iso (Strict.WriterT . Lazy.runWriterT) (Lazy.WriterT . Strict.runWriterT)- {-# INLINE strict #-}--instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where- strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST)- {-# INLINE strict #-}--instance Strict (Lazy.ST s a) (Strict.ST s a) where- strict = iso Lazy.lazyToStrictST Lazy.strictToLazyST- {-# INLINE strict #-}- -- | An 'Iso' between the strict variant of a structure and its lazy -- counterpart. --@@ -561,10 +454,9 @@ -- 'lazy' = 'from' 'strict' -- @ ----- See <http://hackage.haskell.org/package/strict-base-types> for an example--- use. lazy :: Strict lazy strict => Iso' strict lazy-lazy = from strict+lazy = iso toLazy toStrict+{-# INLINE lazy #-} -- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal. --@@ -700,7 +592,6 @@ seconding p = withIso p $ \ sa bt -> iso (second sa) (second bt) {-# INLINE seconding #-} -#if __GLASGOW_HASKELL__ >= 708 -- | Data types that are representationally equal are isomorphic. -- -- This is only available on GHC 7.8+@@ -708,10 +599,13 @@ -- @since 4.13 coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b # if __GLASGOW_HASKELL__ >= 710-coerced l = rmap (fmap coerce') l .# coerce+coerced l = rmap (fmap coerce) l .# coerce # else coerced l = case sym Coercion :: Coercion a s of Coercion -> rmap (fmap coerce') l .# coerce++coerce' :: forall a b. Coercible a b => b -> a+coerce' = coerce (id :: a -> a)+{-# INLINE coerce' #-} # endif {-# INLINE coerced #-}-#endif
src/Control/Lens/Lens.hs view
@@ -109,8 +109,8 @@ -- * ALens Combinators , storing , (^#)- , ( #~ ), ( #%~ ), ( #%%~ ), (<#~), (<#%~)- , ( #= ), ( #%= ), ( #%%= ), (<#=), (<#%=)+ , (#~), (#%~), (#%%~), (<#~), (<#%~)+ , (#=), (#%=), (#%%=), (<#=), (<#%=) -- * Common Lenses , devoid@@ -144,13 +144,10 @@ import GHC.Exts (TYPE) #endif -#ifdef HLINT-{-# ANN module "HLint: ignore Use ***" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Control.Arrow -- >>> import Control.Monad.State -- >>> import Data.Char (chr) -- >>> import Data.List.NonEmpty (NonEmpty ((:|)))@@ -667,7 +664,7 @@ -- -- If you do not need the old value ('Control.Lens.Setter.?~') is more flexible. ----- >>> import Data.Map as Map+-- >>> import qualified Data.Map as Map -- >>> _2.at "hello" <<?~ "world" $ (42,Map.fromList [("goodnight","gracie")]) -- (Nothing,(42,fromList [("goodnight","gracie"),("hello","world")])) --@@ -1365,35 +1362,35 @@ -- -- >>> ("hello","there") & _2 #~ "world" -- ("hello","world")-( #~ ) :: ALens s t a b -> b -> s -> t-( #~ ) l b s = ipeek b (l sell s)-{-# INLINE ( #~ ) #-}+(#~) :: ALens s t a b -> b -> s -> t+(#~) l b s = ipeek b (l sell s)+{-# INLINE (#~) #-} -- | A version of ('Control.Lens.Setter.%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 #%~ length -- ("hello",5)-( #%~ ) :: ALens s t a b -> (a -> b) -> s -> t-( #%~ ) l f s = ipeeks f (l sell s)-{-# INLINE ( #%~ ) #-}+(#%~) :: ALens s t a b -> (a -> b) -> s -> t+(#%~) l f s = ipeeks f (l sell s)+{-# INLINE (#%~) #-} -- | A version of ('%%~') that works on 'ALens'. -- -- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!") -- (5,("hello","world!"))-( #%%~ ) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t-( #%%~ ) l f s = runPretext (l sell s) f-{-# INLINE ( #%%~ ) #-}+(#%%~) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t+(#%%~) l f s = runPretext (l sell s) f+{-# INLINE (#%%~) #-} -- | A version of ('Control.Lens.Setter..=') that works on 'ALens'.-( #= ) :: MonadState s m => ALens s s a b -> b -> m ()+(#=) :: MonadState s m => ALens s s a b -> b -> m () l #= f = modify (l #~ f)-{-# INLINE ( #= ) #-}+{-# INLINE (#=) #-} -- | A version of ('Control.Lens.Setter.%=') that works on 'ALens'.-( #%= ) :: MonadState s m => ALens s s a b -> (a -> b) -> m ()+(#%=) :: MonadState s m => ALens s s a b -> (a -> b) -> m () l #%= f = modify (l #%~ f)-{-# INLINE ( #%= ) #-}+{-# INLINE (#%=) #-} -- | A version of ('<%~') that works on 'ALens'. --@@ -1409,7 +1406,7 @@ {-# INLINE (<#%=) #-} -- | A version of ('%%=') that works on 'ALens'.-( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r+(#%%=) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,1) l #%%= f = State.state $ \s -> runPretext (l sell s) f #else@@ -1419,7 +1416,7 @@ State.put t return r #endif-{-# INLINE ( #%%= ) #-}+{-# INLINE (#%%=) #-} -- | A version of ('Control.Lens.Setter.<.~') that works on 'ALens'. --
src/Control/Lens/Level.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-}--#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-}-#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Level
src/Control/Lens/Operators.hs view
@@ -95,20 +95,20 @@ , (<%@=) , (<<%@=) , (^#)- , ( #~ )- , ( #%~ )- , ( #%%~ )- , ( #= )- , ( #%= )+ , (#~)+ , (#%~)+ , (#%%~)+ , (#=)+ , (#%=) , (<#%~) , (<#%=)- , ( #%%= )+ , (#%%=) , (<#~) , (<#=) -- * "Control.Lens.Plated" , (...) -- * "Control.Lens.Review"- , ( # )+ , (#) -- * "Control.Lens.Setter" , (%~) , (.~)
src/Control/Lens/Plated.hs view
@@ -5,10 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-}--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-} -- gplate1-#endif+{-# LANGUAGE PolyKinds #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} -- template-haskell@@ -121,9 +118,12 @@ import Data.Tree import GHC.Generics -#ifdef HLINT-{-# ANN module "HLint: ignore Reduce duplication" #-}-#endif+-- $setup+-- >>> :set -XDeriveGeneric -XDeriveDataTypeable+-- >>> import Control.Applicative+-- >>> import Data.Data (Data, Typeable)+-- >>> import GHC.Generics (Generic)+-- >>> import Control.Lens -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. --@@ -263,9 +263,6 @@ instance Plated TH.Dec instance Plated TH.Con instance Plated TH.Type-#if !(MIN_VERSION_template_haskell(2,8,0))-instance Plated TH.Kind -- in 2.8 Kind is an alias for Type-#endif instance Plated TH.Stmt instance Plated TH.Pat @@ -436,6 +433,8 @@ -- 'cosmosOf' :: 'Fold' a a -> 'Fold' a a -- @ cosmosOf :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a+-- The 'Contravariant' constraint isn't required for the implementation. Since any 'Traversal' produced with 'cosmosOf' is more likely than+-- not to be broken, the additional constraint serves to restrict 'cosmosOf' to 'Fold's. cosmosOf d f s = f s *> d (cosmosOf d f) s {-# INLINE cosmosOf #-} @@ -729,6 +728,41 @@ ------------------------------------------------------------------------------- -- | Implement 'plate' operation for a type using its 'Generic' instance.+--+-- Note: the behavior may be different than with 'uniplate' in some special cases.+-- 'gplate' doesn't look through other types in a group of mutually+-- recursive types.+--+-- For example consider mutually recursive even and odd natural numbers:+--+-- >>> data Even = Z | E Odd deriving (Show, Generic, Typeable, Data); data Odd = O Even deriving (Show, Generic, Typeable, Data)+--+-- Then 'uniplate', which is based on `Data`, finds+-- all even numbers less or equal than four:+--+-- >>> import Data.Data.Lens (uniplate)+-- >>> universeOf uniplate (E (O (E (O Z))))+-- [E (O (E (O Z))),E (O Z),Z]+--+-- but 'gplate' doesn't see through @Odd@.+--+-- >>> universeOf gplate (E (O (E (O Z))))+-- [E (O (E (O Z)))]+--+-- If using 'Data' is not an option, you can still write the traversal manually.+-- It is sometimes useful to use helper traversals+--+-- >>> :{+-- let oddeven :: Traversal' Odd Even+-- oddeven f (O n) = O <$> f n+-- evenplate :: Traversal' Even Even+-- evenplate f Z = pure Z+-- evenplate f (E n) = E <$> oddeven f n+-- :}+--+-- >>> universeOf evenplate (E (O (E (O Z))))+-- [E (O (E (O Z))),E (O Z),Z]+-- gplate :: (Generic a, GPlated a (Rep a)) => Traversal' a a gplate f x = GHC.Generics.to <$> gplate' f (GHC.Generics.from x) {-# INLINE gplate #-}
src/Control/Lens/Prism.hs view
@@ -59,19 +59,9 @@ import Data.Profunctor.Sieve import Data.Traversable import Data.Void-#if MIN_VERSION_base(4,7,0) import Data.Coerce-#elif defined(SAFE)-import Data.Profunctor.Unsafe-#else-import Unsafe.Coerce-#endif import Prelude -#ifdef HLINT-{-# ANN module "HLint: ignore Use camelCase" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens@@ -97,23 +87,15 @@ -- | Convert 'APrism' to the pair of functions that characterize it. withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r-#if MIN_VERSION_base(4,7,0) withPrism k f = case coerce (k (Market Identity Right)) of Market bt seta -> f bt seta-#elif defined(SAFE)-withPrism k f = case k (Market Identity Right) of- Market bt seta -> f (runIdentity #. bt) (either (Left . runIdentity) Right . seta)-#else-withPrism k f = case unsafeCoerce (k (Market Identity Right)) of- Market bt seta -> f bt seta-#endif {-# INLINE withPrism #-} -- | Clone a 'Prism' so that you can reuse the same monomorphically typed 'Prism' for different purposes. -- -- See 'Control.Lens.Lens.cloneLens' and 'Control.Lens.Traversal.cloneTraversal' for examples of why you might want to do this. clonePrism :: APrism s t a b -> Prism s t a b-clonePrism k = withPrism k prism+clonePrism k = withPrism k $ \bt sta -> prism bt sta {-# INLINE clonePrism #-} ------------------------------------------------------------------------------@@ -150,9 +132,9 @@ without :: APrism s t a b -> APrism u v c d -> Prism (Either s u) (Either t v) (Either a c) (Either b d)-without k =- withPrism k $ \bt seta k' ->- withPrism k' $ \dv uevc ->+without k k' =+ withPrism k $ \bt seta ->+ withPrism k' $ \dv uevc -> prism (bimap bt dv) $ \su -> case su of Left s -> bimap Left Left (seta s)
+ src/Control/Lens/Profunctor.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}+-------------------------------------------------------------------------------+-- | This module provides conversion functions between the optics defined in+-- this library and 'Profunctor'-based optics.+--+-- The goal of these functions is to provide an interoperability layer between+-- the two styles of optics, and not to reimplement all the library in terms of+-- 'Profunctor' optics.++module Control.Lens.Profunctor+ ( -- * Profunctor optic+ OpticP++ -- * Conversion from Van Laarhoven optics+ , fromLens+ , fromIso+ , fromPrism+ , fromSetter+ , fromTraversal++ -- * Conversion to Van Laarhoven optics+ , toLens+ , toIso+ , toPrism+ , toSetter+ , toTraversal+ ) where++import Prelude ()++import Control.Lens.Internal.Prelude+import Control.Lens.Type (Optic, LensLike)+import Control.Lens.Internal.Context (Context (..), sell)+import Control.Lens.Internal.Profunctor (WrappedPafb (..))+import Control.Lens (ASetter, ATraversal, cloneTraversal, Settable)+import Data.Profunctor (Star (..))+import Data.Profunctor.Mapping (Mapping (..))+import Data.Profunctor.Traversing (Traversing (..))++-- | Profunctor optic.+type OpticP p s t a b = p a b -> p s t++--------------------------------------------------------------------------------+-- Conversion from Van Laarhoven optics+--------------------------------------------------------------------------------++-- | Converts a 'Control.Lens.Type.Lens' to a 'Profunctor'-based one.+--+-- @+-- 'fromLens' :: 'Control.Lens.Type.Lens' s t a b -> LensP s t a b+-- @+fromLens :: Strong p => LensLike (Context a b) s t a b -> OpticP p s t a b+fromLens l p =+ dimap+ (\s -> let Context f a = l sell s in (f, a))+ (uncurry id)+ (second' p)++-- | Converts a 'Control.Lens.Type.Iso' to a 'Profunctor'-based one.+--+-- @+-- 'fromIso' :: 'Control.Lens.Type.Iso' s t a b -> IsoP s t a b+-- @+fromIso :: Profunctor p => Optic p Identity s t a b -> OpticP p s t a b+fromIso p pab = rmap runIdentity (p (rmap Identity pab))++-- | Converts a 'Control.Lens.Type.Prism' to a 'Profunctor'-based one.+--+-- @+-- 'fromPrism' :: 'Control.Lens.Type.Prism' s t a b -> PrismP s t a b+-- @+fromPrism :: Choice p => Optic p Identity s t a b -> OpticP p s t a b+fromPrism p pab = rmap runIdentity (p (rmap Identity pab))++-- | Converts a 'Control.Lens.Type.Setter' to a 'Profunctor'-based one.+--+-- @+-- 'fromSetter' :: 'Control.Lens.Type.Setter' s t a b -> SetterP s t a b+-- @+fromSetter :: Mapping p => ASetter s t a b -> OpticP p s t a b+fromSetter s = roam s'+ where+ s' f = runIdentity . s (Identity . f)++-- | Converts a 'Control.Lens.Type.Traversal' to a 'Profunctor'-based one.+--+-- @+-- 'fromTraversal' :: 'Control.Lens.Type.Traversal' s t a b -> TraversalP s t a b+-- @+fromTraversal :: Traversing p => ATraversal s t a b -> OpticP p s t a b+fromTraversal l = wander (cloneTraversal l)++--------------------------------------------------------------------------------+-- Conversion to Van Laarhoven optics+--------------------------------------------------------------------------------++-- | Obtain a 'Control.Lens.Type.Prism' from a 'Profunctor'-based one.+--+-- @+-- 'toPrism' :: PrismP s t a b -> 'Control.Lens.Type.Prism' s t a b+-- @+toPrism :: (Choice p, Applicative f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b+toPrism p = unwrapPafb . p . WrapPafb++-- | Obtain a 'Control.Lens.Type.Iso' from a 'Profunctor'-based one.+--+-- @+-- 'toIso' :: IsoP s t a b -> 'Control.Lens.Type.Iso' s t a b+-- @+toIso :: (Profunctor p, Functor f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b+toIso p = unwrapPafb . p . WrapPafb++-- | Obtain a 'Control.Lens.Type.Lens' from a 'Profunctor'-based one.+--+-- @+-- 'toLens' :: LensP s t a b -> 'Control.Lens.Type.Lens' s t a b+-- @+toLens :: Functor f => OpticP (Star f) s t a b -> LensLike f s t a b+toLens p = runStar . p . Star++-- | Obtain a 'Control.Lens.Type.Setter' from a 'Profunctor'-based one.+--+-- @+-- 'toSetter' :: SetterP s t a b -> 'Control.Lens.Type.Setter' s t a b+-- @+toSetter :: Settable f => OpticP (Star f) s t a b -> LensLike f s t a b+toSetter p = runStar . p . Star++-- | Obtain a 'Control.Lens.Type.Traversal' from a 'Profunctor'-based one.+--+-- @+-- 'toTraversal' :: TraversalP s t a b -> 'Control.Lens.Type.Traversal' s t a b+-- @+toTraversal :: Applicative f => OpticP (Star f) s t a b -> LensLike f s t a b+toTraversal p = runStar . p . Star
src/Control/Lens/Reified.hs view
@@ -44,6 +44,7 @@ -- $setup -- >>> import Control.Lens+-- >>> import Control.Applicative ------------------------------------------------------------------------------ -- Lens@@ -256,7 +257,7 @@ {-# INLINE dimap #-} instance Sieve (ReifiedIndexedGetter i) ((,) i) where- sieve = iview . runIndexedGetter+ sieve (IndexedGetter l) = iview l {-# INLINE sieve #-} instance Representable (ReifiedIndexedGetter i) where@@ -307,7 +308,7 @@ {-# INLINE lmap #-} instance Sieve ReifiedFold [] where- sieve = toListOf . runFold+ sieve (Fold l) = toListOf l instance Representable ReifiedFold where type Rep ReifiedFold = []
src/Control/Lens/Review.hs view
@@ -27,10 +27,11 @@ , re , review, reviews , reuse, reuses- , ( # )+ , (#) , Bifunctor(bimap) , retagged , Reviewable+ , reviewing ) where import Control.Monad.Reader as Reader@@ -48,7 +49,9 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Control.Monad.State -- >>> import Numeric.Lens+-- >>> import Data.Semigroup (Semigroup (..)) -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False @@ -164,9 +167,9 @@ -- (#) :: 'Review' s a -> a -> s -- (#) :: 'Equality'' s a -> a -> s -- @-( # ) :: AReview t b -> b -> t-( # ) p = runIdentity #. unTagged #. p .# Tagged .# Identity-{-# INLINE ( # ) #-}+(#) :: AReview t b -> b -> t+(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity+{-# INLINE (#) #-} -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way, -- applying a function.@@ -240,3 +243,13 @@ reuses :: MonadState b m => AReview t b -> (t -> r) -> m r reuses p tr = gets (tr . runIdentity #. unTagged #. p .# Tagged .# Identity) {-# INLINE reuses #-}++-- | Coerce a polymorphic 'Prism' to a 'Review'.+--+-- @+-- 'reviewing' :: 'Iso' s t a b -> 'Review' t b+-- 'reviewing' :: 'Prism' s t a b -> 'Review' t b+-- @+reviewing :: (Bifunctor p, Functor f) => Optic Tagged Identity s t a b -> Optic' p f t b+reviewing p = bimap f (fmap f) where+ f = runIdentity . unTagged . p . Tagged . Identity
src/Control/Lens/Setter.hs view
@@ -89,18 +89,13 @@ import Control.Monad.State.Class as State import Control.Monad.Writer.Class as Writer -#ifdef HLINT-{-# ANN module "HLint: ignore Avoid lambda" #-}-{-# ANN module "HLint: ignore Use fmap" #-}-#endif- -- $setup -- >>> import Control.Lens -- >>> import Control.Monad.State -- >>> import Data.Char -- >>> import Data.Functor.Contravariant (Predicate (..), Op (..))--- >>> import Data.Map as Map--- >>> import Data.Semigroup (Sum (..), Product (..))+-- >>> import qualified Data.Map as Map+-- >>> import Data.Semigroup (Sum (..), Product (..), Semigroup (..)) -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -532,7 +527,7 @@ -- -- If you do not need a copy of the intermediate result, then using @l '?~' d@ directly is a good idea. ----- >>> import Data.Map as Map+-- >>> import qualified Data.Map as Map -- >>> _2.at "hello" <?~ "world" $ (42,Map.fromList [("goodnight","gracie")]) -- ("world",(42,fromList [("goodnight","gracie"),("hello","world")])) --
src/Control/Lens/TH.hs view
@@ -81,9 +81,6 @@ import Prelude () -#if !(MIN_VERSION_template_haskell(2,7,0))-import Control.Monad (ap)-#endif import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.Trans.Writer@@ -109,16 +106,14 @@ import Data.Set (Set) import Data.Set.Lens import Data.Traversable hiding (mapM)-import Language.Haskell.TH import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Lens-import Language.Haskell.TH.Syntax hiding (lift)--#ifdef HLINT-{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Use fewer imports" #-}-{-# ANN module "HLint: ignore Use foldl" #-}+import Language.Haskell.TH.Lib+#if MIN_VERSION_template_haskell(2,15,0)+import Language.Haskell.TH.Ppr (pprint) #endif+import Language.Haskell.TH.Syntax hiding (lift) -- | Generate "simple" optics even when type-changing optics are possible. -- (e.g. 'Lens'' instead of 'Lens')@@ -519,7 +514,7 @@ -> Just DataDecl { dataContext = ctx , tyConName = Nothing- , dataParameters = map PlainTV vars+ , dataParameters = map D.plainTV vars , fullType = \tys -> apps (ConT familyName) $ substType (Map.fromList $ zip vars tys) args , constructors = cons@@ -547,7 +542,7 @@ { dataContext :: Cxt -- ^ Datatype context. , tyConName :: Maybe Name -- ^ Type constructor name, or Nothing for a data family instance.- , dataParameters :: [TyVarBndr] -- ^ List of type parameters+ , dataParameters :: [TyVarBndrUnit] -- ^ List of type parameters , fullType :: [Type] -> Type -- ^ Create a concrete record type given a substitution to -- 'detaParameters'.@@ -633,13 +628,6 @@ -- _Wrapped' = iso (\(Con x) -> x) Con instanceD (cxt []) klass [unwrappedATF, isoMethod] -#if !(MIN_VERSION_template_haskell(2,7,0))--- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse.-instance Applicative Q where- pure = return- (<*>) = ap-#endif- overHead :: (a -> a) -> [a] -> [a] overHead _ [] = [] overHead f (x:xs) = f x : xs@@ -857,7 +845,7 @@ -- | Traverse each data, newtype, data instance or newtype instance -- declaration. traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]-traverseDataAndNewtype f decs = traverse go decs+traverseDataAndNewtype f = traverse go where go dec = case dec of DataD{} -> f dec
src/Control/Lens/Traversal.hs view
@@ -167,9 +167,11 @@ -- >>> :set -XNoOverloadedStrings -XFlexibleContexts -- >>> import Data.Char (toUpper) -- >>> import Control.Lens+-- >>> import Control.Lens.Internal.Context -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate,try,ErrorCall(..)) -- >>> import Data.Maybe (fromMaybe)+-- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Debug.SimpleReflect.Vars -- >>> import Data.Void -- >>> import Data.List (sort)@@ -734,7 +736,7 @@ {-# INLINABLE holeInOne #-} -- | The non-empty version of 'holesOf'.--- This extract a non-empty list of immediate children accroding to a given+-- This extract a non-empty list of immediate children according to a given -- 'Traversal1' as editable contexts. -- -- >>> let head1 f s = runPretext (NonEmpty.head $ holes1Of traversed1 s) f@@ -1161,11 +1163,7 @@ instance TraverseMin Int IntMap.IntMap where traverseMin f m = case IntMap.minViewWithKey m of-#if MIN_VERSION_containers(0,5,0) Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const (Just v)) m-#else- Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const v) m-#endif Nothing -> pure m {-# INLINE traverseMin #-} @@ -1182,11 +1180,7 @@ instance TraverseMax Int IntMap.IntMap where traverseMax f m = case IntMap.maxViewWithKey m of-#if MIN_VERSION_containers(0,5,0) Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const (Just v)) m-#else- Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const v) m-#endif Nothing -> pure m {-# INLINE traverseMax #-} @@ -1228,7 +1222,7 @@ -- 'element' ≡ 'elementOf' 'traverse' -- @ element :: Traversable t => Int -> IndexedTraversal' Int (t a) a-element = elementOf traverse+element i = elementOf traverse i {-# INLINE element #-} -- | Traverse (or fold) selected elements of a 'Traversal' (or 'Fold') where their ordinal positions match a predicate.@@ -1250,7 +1244,7 @@ -- 'elements' ≡ 'elementsOf' 'traverse' -- @ elements :: Traversable t => (Int -> Bool) -> IndexedTraversal' Int (t a) a-elements = elementsOf traverse+elements i = elementsOf traverse i {-# INLINE elements #-} -- | Try to map a function over this 'Traversal', failing if the 'Traversal' has no targets.
src/Control/Lens/Tuple.hs view
@@ -10,9 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-}-#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif #include "lens-common.h" @@ -58,6 +56,7 @@ import Control.Lens.Lens import Control.Lens.Internal.Prelude import Data.Functor.Product (Product (..))+import Data.Strict (Pair (..)) import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..), U1 (..)) @@ -109,6 +108,10 @@ instance Field1 ((f :*: g) p) ((f' :*: g) p) (f p) (f' p) where _1 f (l :*: r) = (:*: r) <$> f l +-- | @since 4.20+instance Field1 (Pair a b) (Pair a' b) a a' where+ _1 f (a :!: b) = (:!: b) <$> f a+ -- | @ -- '_1' k ~(a,b) = (\\a' -> (a',b)) 'Data.Functor.<$>' k a -- @@@ -215,6 +218,10 @@ instance Field2 ((f :*: g) p) ((f :*: g') p) (g p) (g' p) where _2 f (l :*: r) = (l :*:) <$> f r +-- | @since 4.20+instance Field2 (Pair a b) (Pair a b') b b' where+ _2 f (a :!: b) = (a :!:) <$> f b+ -- | @ -- '_2' k ~(a,b) = (\\b' -> (a,b')) 'Data.Functor.<$>' k b -- @@@ -1182,14 +1189,12 @@ gix = gix' (Proxy :: Proxy p) {-# INLINE gix #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 -- $gixed-fundeps -- >>> :set -XDeriveGeneric -XFlexibleInstances -XMultiParamTypeClasses -- >>> import GHC.Generics (Generic) -- >>> data Product a b = a :* b deriving Generic -- >>> instance Field1 (Product a b) (Product a' b) a a' -- >>> instance Field2 (Product a b) (Product a b') b b'-#endif class (p ~ GT (GSize s) n, p ~ GT (GSize t) n)
src/Control/Lens/Type.hs view
@@ -5,10 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE KindSignatures #-}-#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-} #endif@@ -464,10 +461,8 @@ -- Note: Composition with an 'Equality' is index-preserving. #if __GLASGOW_HASKELL__ >= 800 type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall k3 (p :: k1 -> k3 -> Type) (f :: k2 -> k3) .-#elif __GLASGOW_HASKELL__ >= 706-type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall (p :: k1 -> * -> *) (f :: k2 -> *) . #else-type Equality s t a b = forall p (f :: * -> *) .+type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall (p :: k1 -> * -> *) (f :: k2 -> *) . #endif p a (f b) -> p s (f t)
src/Control/Lens/Unsound.hs view
@@ -3,14 +3,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}--#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-}-#endif- {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+ ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Unsound@@ -37,6 +34,10 @@ import Control.Lens.Internal.Prelude import Prelude () +-- $setup+-- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens+ -- | A lens product. There is no law-abiding way to do this in general. -- Result is only a valid 'Lens' if the input lenses project disjoint parts of -- the structure @s@. Otherwise "you get what you put in" law@@ -80,9 +81,9 @@ prismSum :: APrism s t a b -> APrism s t c d -> Prism s t (Either a c) (Either b d)-prismSum k =- withPrism k $ \bt seta k' ->- withPrism k' $ \dt setb ->+prismSum k k' =+ withPrism k $ \bt seta ->+ withPrism k' $ \dt setb -> prism (either bt dt) $ \s -> f (Left <$> seta s) (Right <$> setb s) where
src/Control/Lens/Wrapped.hs view
@@ -7,10 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}--#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-}@@ -129,12 +126,17 @@ import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable-import Data.IntSet as IntSet-import Data.IntMap as IntMap-import Data.HashSet as HashSet-import Data.HashMap.Lazy as HashMap-import Data.List.NonEmpty-import Data.Map as Map+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.HashSet as HashSet+import Data.HashSet (HashSet)+import qualified Data.HashMap.Lazy as HashMap+import Data.HashMap.Lazy (HashMap)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Map as Map+import Data.Map (Map) import Data.Monoid import qualified Data.Profunctor as Profunctor import Data.Profunctor hiding (WrappedArrow(..))@@ -143,36 +145,34 @@ import Data.Semigroupoid import qualified Data.Semigroupoid.Dual as Semigroupoid import Data.Semigroupoid.Static-import Data.Sequence as Seq hiding (length)-import Data.Set as Set+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+import qualified Data.Set as Set+import Data.Set (Set) import Data.Tagged-import Data.Vector as Vector-import Data.Vector.Primitive as Prim-import Data.Vector.Unboxed as Unboxed-import Data.Vector.Storable as Storable+import qualified Data.Vector as Vector+import qualified Data.Vector.Primitive as Prim+import Data.Vector.Primitive (Prim)+import qualified Data.Vector.Unboxed as Unboxed+import Data.Vector.Unboxed (Unbox)+import qualified Data.Vector.Storable as Storable import Foreign.C.Error import Foreign.C.Types+import Foreign.Storable (Storable) import qualified GHC.Generics as Generic import GHC.Generics hiding (from, to) import System.Posix.Types--#if MIN_VERSION_base(4,6,0) import Data.Ord (Down(Down))-#else-import GHC.Exts (Down(Down))-#endif #if MIN_VERSION_base(4,8,0) import qualified Data.Monoid as Monoid #endif -#ifdef HLINT-{-# ANN module "HLint: ignore Use uncurry" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Data.Foldable (foldMap)+-- >>> import Data.Monoid (Sum (..), Product (..), All (..), Any (..)) -- | 'Wrapped' provides isomorphisms to wrap and unwrap newtypes or -- data types with one constructor.@@ -1357,7 +1357,7 @@ -- @ ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)-ala = xplat . _Unwrapping+ala f = xplat $ _Unwrapping f {-# INLINE ala #-} -- | This combinator is based on @ala'@ from Conor McBride's work on Epigram.@@ -1371,5 +1371,5 @@ -- >>> alaf Sum foldMap Prelude.length ["hello","world"] -- 10 alaf :: (Functor f, Functor g, Rewrapping s t) => (Unwrapped s -> s) -> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s)-alaf = xplatf . _Unwrapping+alaf f = xplatf $ _Unwrapping f {-# INLINE alaf #-}
src/Control/Lens/Zoom.hs view
@@ -6,10 +6,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}--#if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-}-#endif #include "lens-common.h" @@ -53,14 +50,11 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Free -#ifdef HLINT-{-# ANN module "HLint: ignore Use fmap" #-}-#endif- -- $setup -- >>> import Control.Lens--- >>> import Control.Monad.State--- >>> import Data.Map as Map+-- >>> import Control.Monad.State as State+-- >>> import Control.Monad.Reader as Reader+-- >>> import qualified Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
src/Control/Monad/Error/Lens.hs view
@@ -40,10 +40,6 @@ import Data.Semigroup (Semigroup(..)) #endif -#ifdef HLINT-{-# ANN module "HLint: ignore Use fmap" #-}-#endif- ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------
src/Data/Array/Lens.hs view
@@ -30,5 +30,5 @@ -- 'bounds' ('over' ('ixmapped' b) f arr) ≡ b -- @ ixmapped :: (IArray a e, Ix i, Ix j) => (i,i) -> IndexPreservingSetter (a j e) (a i e) i j-ixmapped = setting . ixmap+ixmapped i = setting $ ixmap i {-# INLINE ixmapped #-}
src/Data/Bits/Lens.hs view
@@ -28,9 +28,10 @@ import Data.Bits import Data.Word - -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens+-- >>> import Control.Monad.State -- >>> import Data.Word infixr 4 .|.~, .&.~, <.|.~, <.&.~, <<.|.~, <<.&.~
src/Data/ByteString/Lazy/Lens.hs view
@@ -28,14 +28,17 @@ import Control.Lens import Control.Lens.Internal.ByteString-import Data.ByteString.Lazy as Words-import Data.ByteString.Lazy.Char8 as Char8+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as Words+import qualified Data.ByteString.Lazy.Char8 as Char8 import Data.Word (Word8) import Data.Int (Int64) -- $setup -- >>> :set -XOverloadedStrings+-- >>> import Control.Lens -- >>> import Numeric.Lens+-- >>> import qualified Data.ByteString.Lazy.Char8 as Char8 -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString'. --@@ -48,7 +51,7 @@ -- >>> [104,101,108,108,111]^.packedBytes == Char8.pack "hello" -- True packedBytes :: Iso' [Word8] ByteString-packedBytes = iso Words.pack unpackLazy+packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} -- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a 'ByteString' into a list of bytes@@ -99,7 +102,7 @@ -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString-packedChars = iso Char8.pack unpackLazy8+packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} -- | 'Data.ByteString.Lazy.Char8.unpack' (or 'Data.ByteString.Lazy.Char8.pack') a list of characters into a 'ByteString'
src/Data/ByteString/Lens.hs view
@@ -26,9 +26,9 @@ import Control.Lens import Data.Word (Word8)-import Data.ByteString as Strict+import qualified Data.ByteString as Strict import qualified Data.ByteString.Strict.Lens as Strict-import Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Lens as Lazy -- | Traversals for ByteStrings.@@ -113,7 +113,7 @@ #if __GLASGOW_HASKELL__ >= 710 pattern Bytes b <- (view unpackedBytes -> b) where Bytes b = review unpackedBytes b- + pattern Chars b <- (view unpackedChars -> b) where Chars b = review unpackedChars b #endif
src/Data/ByteString/Strict/Lens.hs view
@@ -26,14 +26,16 @@ import Control.Lens import Control.Lens.Internal.ByteString-import Data.ByteString as Words-import Data.ByteString.Char8 as Char8+import Data.ByteString (ByteString)+import qualified Data.ByteString as Words+import qualified Data.ByteString.Char8 as Char8 import Data.Word -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens -- >>> import Numeric.Lens+-- >>> import qualified Data.ByteString.Char8 as Char8 -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' --@@ -46,7 +48,7 @@ -- >>> [104,101,108,108,111]^.packedBytes -- "hello" packedBytes :: Iso' [Word8] ByteString-packedBytes = iso Words.pack unpackStrict+packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes@@ -97,7 +99,7 @@ -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString-packedChars = iso Char8.pack unpackStrict8+packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a 'ByteString'
src/Data/Complex/Lens.hs view
@@ -40,6 +40,8 @@ import Data.Complex -- $setup+-- >>> import Control.Lens+-- >>> import Data.Complex -- >>> import Debug.SimpleReflect -- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ }
src/Data/Data/Lens.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-}-#ifndef HLINT {-# LANGUAGE UnboxedTuples #-}-#endif {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}@@ -74,16 +72,9 @@ import Prelude import qualified Data.Proxy as X (Proxy (..))-import qualified Control.Lens.Internal.Typeable as X+import qualified Data.Typeable as X (typeRep, eqT) import qualified Data.Type.Equality as X -#ifdef HLINT-{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Use foldl" #-}-{-# ANN module "HLint: ignore Reduce duplication" #-}-{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}-#endif- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens@@ -332,13 +323,11 @@ where x' = f x {-# INLINE fixEq #-} -#ifndef HLINT -- | inlineable 'unsafePerformIO' inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-}-#endif ------------------------------------------------------------------------------- -- Cache@@ -402,7 +391,7 @@ biplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s-biplateData o f a0 = go2 a0 where+biplateData o f = go2 where go :: Data d => d -> f d go s = gfoldl (\x y -> x <*> go2 y) pure s go2 :: Data d => d -> f d@@ -413,7 +402,7 @@ {-# INLINE biplateData #-} uniplateData :: forall f s a. (Applicative f, Data s) => (forall c. Typeable c => c -> Answer c a) -> (a -> f a) -> s -> f s-uniplateData o f a0 = go a0 where+uniplateData o f = go where go :: Data d => d -> f d go s = gfoldl (\x y -> x <*> go2 y) pure s go2 :: Data d => d -> f d
src/Data/HashSet/Lens.hs view
@@ -17,7 +17,8 @@ import Control.Lens.Getter (Getting, views) import Control.Lens.Setter (setting) import Control.Lens.Type-import Data.HashSet as HashSet+import qualified Data.HashSet as HashSet+import Data.HashSet (HashSet) import Data.Hashable -- $setup
src/Data/IntSet/Lens.hs view
@@ -16,11 +16,13 @@ ) where import Control.Lens-import Data.IntSet as IntSet+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import qualified Data.IntSet as IntSet -- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of an 'IntSet'. --@@ -37,7 +39,7 @@ -- elements might change but you can manipulate it by reading using 'folded' and -- reindexing it via 'setmapped'. ----- >>> over setmapped (+1) (fromList [1,2,3,4])+-- >>> over setmapped (+1) (IntSet.fromList [1,2,3,4]) -- fromList [2,3,4,5] setmapped :: IndexPreservingSetter' IntSet Int setmapped = setting IntSet.map
src/Data/List/Lens.hs view
@@ -99,10 +99,11 @@ import Control.Monad (guard) import Control.Lens.Internal.Prelude import Control.Lens-import Data.List+import qualified Data.List as List -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -120,7 +121,7 @@ -- >>> prefixed "pre" # "amble" -- "preamble" prefixed :: Eq a => [a] -> Prism' [a] [a]-prefixed ps = prism' (ps ++) (stripPrefix ps)+prefixed ps = prism' (ps ++) (List.stripPrefix ps) {-# INLINE prefixed #-} -- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or
src/Data/Map/Lens.hs view
@@ -70,6 +70,7 @@ -- $setup -- >>> import Control.Lens -- >>> import Data.Monoid+-- >>> import qualified Data.Map as Map -- >>> :set -XNoOverloadedStrings -- | Construct a map from a 'IndexedGetter', 'Control.Lens.Fold.IndexedFold', 'Control.Lens.Traversal.IndexedTraversal' or 'Control.Lens.Lens.IndexedLens'
src/Data/Sequence/Lens.hs view
@@ -19,10 +19,14 @@ import Control.Applicative import Control.Lens import Data.Monoid-import Data.Sequence as Seq+import qualified Data.Sequence as Seq+import Data.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), (><), viewl, viewr) import Prelude -- $setup+-- >>> import Control.Lens+-- >>> import qualified Data.Sequence as Seq+-- >>> import Data.Sequence (ViewL(EmptyL), ViewR(EmptyR)) -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -43,7 +47,7 @@ -- >>> EmptyL ^. from viewL -- fromList [] ----- >>> review viewL $ a Seq.:< fromList [b,c]+-- >>> review viewL $ a Seq.:< Seq.fromList [b,c] -- fromList [a,b,c] viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) viewL = iso viewl $ \ xs -> case xs of@@ -64,7 +68,7 @@ -- >>> EmptyR ^. from viewR -- fromList [] ----- >>> review viewR $ fromList [a,b] Seq.:> c+-- >>> review viewR $ Seq.fromList [a,b] Seq.:> c -- fromList [a,b,c] viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) viewR = iso viewr $ \xs -> case xs of@@ -74,13 +78,13 @@ -- | Traverse the first @n@ elements of a 'Seq' ----- >>> fromList [a,b,c,d,e] ^.. slicedTo 2+-- >>> Seq.fromList [a,b,c,d,e] ^.. slicedTo 2 -- [a,b] ----- >>> fromList [a,b,c,d,e] & slicedTo 2 %~ f+-- >>> Seq.fromList [a,b,c,d,e] & slicedTo 2 %~ f -- fromList [f a,f b,c,d,e] ----- >>> fromList [a,b,c,d,e] & slicedTo 10 .~ x+-- >>> Seq.fromList [a,b,c,d,e] & slicedTo 10 .~ x -- fromList [x,x,x,x,x] slicedTo :: Int -> IndexedTraversal' Int (Seq a) a slicedTo n f m = case Seq.splitAt n m of@@ -89,13 +93,13 @@ -- | Traverse all but the first @n@ elements of a 'Seq' ----- >>> fromList [a,b,c,d,e] ^.. slicedFrom 2+-- >>> Seq.fromList [a,b,c,d,e] ^.. slicedFrom 2 -- [c,d,e] ----- >>> fromList [a,b,c,d,e] & slicedFrom 2 %~ f+-- >>> Seq.fromList [a,b,c,d,e] & slicedFrom 2 %~ f -- fromList [a,b,f c,f d,f e] ----- >>> fromList [a,b,c,d,e] & slicedFrom 10 .~ x+-- >>> Seq.fromList [a,b,c,d,e] & slicedFrom 10 .~ x -- fromList [a,b,c,d,e] slicedFrom :: Int -> IndexedTraversal' Int (Seq a) a slicedFrom n f m = case Seq.splitAt n m of@@ -104,13 +108,13 @@ -- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' ----- >>> fromList [a,b,c,d,e] & sliced 1 3 %~ f+-- >>> Seq.fromList [a,b,c,d,e] & sliced 1 3 %~ f -- fromList [a,f b,f c,d,e] --- >>> fromList [a,b,c,d,e] ^.. sliced 1 3+-- >>> Seq.fromList [a,b,c,d,e] ^.. sliced 1 3 -- [f b,f c] ----- >>> fromList [a,b,c,d,e] & sliced 1 3 .~ x+-- >>> Seq.fromList [a,b,c,d,e] & sliced 1 3 .~ x -- fromList [a,x,x,b,e] sliced :: Int -> Int -> IndexedTraversal' Int (Seq a) a sliced i j f s = case Seq.splitAt i s of
src/Data/Set/Lens.hs view
@@ -23,12 +23,14 @@ import Control.Lens.Getter ( Getting, views ) import Control.Lens.Setter ( setting ) import Control.Lens.Type-import Data.Set as Set+import qualified Data.Set as Set+import Data.Set (Set) -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import qualified Data.Set as Set -- | This 'Setter' can be used to change the type of a 'Set' by mapping -- the elements to new values.@@ -36,13 +38,9 @@ -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. ----- >>> over setmapped (+1) (fromList [1,2,3,4])+-- >>> over setmapped (+1) (Set.fromList [1,2,3,4]) -- fromList [2,3,4,5]-#if MIN_VERSION_containers(0,5,2) setmapped :: Ord j => IndexPreservingSetter (Set i) (Set j) i j-#else-setmapped :: (Ord i, Ord j) => IndexPreservingSetter (Set i) (Set j) i j-#endif setmapped = setting Set.map {-# INLINE setmapped #-}
src/Data/Text/Lazy/Lens.hs view
@@ -36,15 +36,18 @@ #endif import Control.Lens.Setter import Control.Lens.Traversal-import Data.ByteString.Lazy as ByteString+import Data.ByteString.Lazy (ByteString) import Data.Monoid-import Data.Text.Lazy as Text-import Data.Text.Lazy.Builder+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as Text+import qualified Data.Text.Lazy.Builder as Builder+import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Encoding -- $setup -- >>> :set -XOverloadedStrings -- >>> import Control.Lens+-- >>> import qualified Data.ByteString.Lazy as ByteString -- | This isomorphism can be used to 'pack' (or 'unpack') lazy 'Text'. --@@ -98,7 +101,7 @@ -- 'toLazyText' x ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder-builder = iso fromLazyText toLazyText+builder = iso Builder.fromLazyText Builder.toLazyText {-# INLINE builder #-} -- | Traverse the individual characters in a 'Text'.
src/Data/Text/Lens.hs view
@@ -32,14 +32,15 @@ #endif import Control.Lens.Iso import Control.Lens.Traversal-import Data.Text as Strict+import qualified Data.Text as Strict import qualified Data.Text.Strict.Lens as Strict-import Data.Text.Lazy as Lazy+import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.Lens as Lazy-import Data.Text.Lazy.Builder+import Data.Text.Lazy.Builder (Builder) -- $setup -- >>> import Control.Lens+-- >>> import qualified Data.Text as Strict -- | Traversals for strict or lazy 'Text' class IsText t where
src/Data/Text/Strict/Lens.hs view
@@ -37,10 +37,12 @@ import Control.Lens.Traversal import Data.ByteString (ByteString) import Data.Monoid-import Data.Text as Strict+import qualified Data.Text as Strict+import Data.Text (Text) import Data.Text.Encoding import Data.Text.Lazy (toStrict)-import Data.Text.Lazy.Builder+import qualified Data.Text.Lazy.Builder as Builder+import Data.Text.Lazy.Builder (Builder) -- $setup -- >>> :set -XOverloadedStrings@@ -59,7 +61,7 @@ -- 'packed' ≡ 'iso' 'pack' 'unpack' -- @ packed :: Iso' String Text-packed = iso pack unpack+packed = iso Strict.pack Strict.unpack {-# INLINE packed #-} -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'.@@ -79,7 +81,7 @@ -- 'unpacked' ≡ 'iso' 'unpack' 'pack' -- @ unpacked :: Iso' Text String-unpacked = iso unpack pack+unpacked = iso Strict.unpack Strict.pack {-# INLINE unpacked #-} -- | This is an alias for 'unpacked' that makes it more obvious how to use it with '#'@@ -97,7 +99,7 @@ -- 'toStrict' ('toLazyText' x) ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder-builder = iso fromText (toStrict . toLazyText)+builder = iso Builder.fromText (toStrict . Builder.toLazyText) {-# INLINE builder #-} -- | Traverse the individual characters in strict 'Text'.
src/Data/Tree/Lens.hs view
@@ -23,6 +23,10 @@ import Control.Lens import Data.Tree +-- $setup+-- >>> import Control.Lens+-- >>> import Data.Tree+ -- | A 'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 []
src/Data/Vector/Generic/Lens.hs view
@@ -36,7 +36,8 @@ , vectorTraverse ) where -import Control.Applicative+import Prelude ()+ import Control.Lens.Type import Control.Lens.Lens import Control.Lens.Getter@@ -46,10 +47,10 @@ import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Internal.List (ordinalNub)-import Data.Monoid-import Data.Vector.Generic as V hiding (zip, filter, indexed)+import Control.Lens.Internal.Prelude+import qualified Data.Vector.Generic as V+import Data.Vector.Generic (Vector) import Data.Vector.Generic.New (New)-import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse) #if MIN_VERSION_vector(0,11,0) import Data.Vector.Fusion.Bundle (Bundle)@@ -58,7 +59,8 @@ #endif -- $setup--- >>> import Data.Vector as Vector+-- >>> import qualified Data.Vector as Vector+-- >>> import Control.Lens -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting -- at index @i@ from a 'Lens'.@@ -78,7 +80,7 @@ => Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Lens' (v a) (v a)-sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (V.toList v0)+sliced i n f v = f (V.slice i n v) <&> \ v0 -> v V.// zip [i..i+n-1] (V.toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'.@@ -86,7 +88,7 @@ -- >>> (toVectorOf both (8,15) :: Vector.Vector Int) == Vector.fromList [8,15] -- True toVectorOf :: Vector v a => Getting (Endo [a]) s a -> s -> v a-toVectorOf l s = fromList (toListOf l s)+toVectorOf l s = V.fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back.)@@ -97,7 +99,7 @@ -- >>> Vector.fromList [0,8,15] ^. from vector -- [0,8,15] vector :: (Vector v a, Vector v b) => Iso [a] [b] (v a) (v b)-vector = iso fromList V.toList+vector = iso V.fromList V.toList {-# INLINE vector #-} #if MIN_VERSION_vector(0,11,0)@@ -107,7 +109,7 @@ -- | Convert a 'Vector' to a finite 'Stream' (or back.) asStream :: (Vector v a, Vector v b) => Iso (v a) (v b) (Stream a) (Stream b) #endif-asStream = iso stream unstream+asStream = iso V.stream V.unstream {-# INLINE asStream #-} #if MIN_VERSION_vector(0,11,0)@@ -119,19 +121,19 @@ -- back.) asStreamR :: (Vector v a, Vector v b) => Iso (v a) (v b) (Stream a) (Stream b) #endif-asStreamR = iso streamR unstreamR+asStreamR = iso V.streamR V.unstreamR {-# INLINE asStreamR #-} -- | Convert a 'Vector' back and forth to an initializer that when run -- produces a copy of the 'Vector'. cloned :: Vector v a => Iso' (v a) (New v a)-cloned = iso clone new+cloned = iso V.clone V.new {-# INLINE cloned #-} -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. forced :: Vector v a => Iso' (v a) (v a)-forced = involuted force+forced = involuted V.force {-# INLINE forced #-} -- | This 'Traversal' will ignore any duplicates in the supplied list@@ -140,7 +142,7 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: Vector v a => [Int] -> IndexedTraversal' Int (v a) a-ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ ordinalNub (length v) is+ordinals is f v = fmap (v V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (V.length v) is {-# INLINE ordinals #-} -- | Like 'ix' but polymorphic in the vector type.@@ -164,4 +166,4 @@ -- | Different vector implementations are isomorphic to each other. converted :: (Vector v a, Vector w a, Vector v b, Vector w b) => Iso (v a) (v b) (w a) (w b)-converted = iso convert convert+converted = iso V.convert V.convert
src/Data/Vector/Lens.hs view
@@ -28,13 +28,18 @@ , ordinals ) where -import Control.Applicative+import Prelude ()+ import Control.Lens import Control.Lens.Internal.List (ordinalNub)-import Data.Vector as Vector hiding (zip, filter, indexed)-import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse)-import Data.Monoid+import Control.Lens.Internal.Prelude+import qualified Data.Vector as V+import Data.Vector (Vector) +-- $setup+-- >>> import qualified Data.Vector as Vector+-- >>> import Control.Lens+ -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting -- at index @i@ from a 'Lens'. --@@ -52,7 +57,7 @@ sliced :: Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Lens' (Vector a) (Vector a)-sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (toList v0)+sliced i n f v = f (V.slice i n v) <&> \ v0 -> v V.// zip [i..i+n-1] (V.toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'.@@ -60,7 +65,7 @@ -- >>> toVectorOf both (8,15) == Vector.fromList [8,15] -- True toVectorOf :: Getting (Endo [a]) s a -> s -> Vector a-toVectorOf l s = fromList (toListOf l s)+toVectorOf l s = V.fromList (toListOf l s) {-# INLINE toVectorOf #-} -- | Convert a list to a 'Vector' (or back)@@ -74,13 +79,13 @@ -- >>> Vector.fromList [0,8,15] ^. from vector . vector == Vector.fromList [0,8,15] -- True vector :: Iso [a] [b] (Vector a) (Vector b)-vector = iso fromList toList+vector = iso V.fromList V.toList {-# INLINE vector #-} -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b)-forced = iso force force+forced = iso V.force V.force {-# INLINE forced #-} -- | This 'Traversal' will ignore any duplicates in the supplied list@@ -89,5 +94,5 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: [Int] -> IndexedTraversal' Int (Vector a) a-ordinals is f v = fmap (v //) $ traverse (\i -> (,) i <$> indexed f i (v ! i)) $ ordinalNub (length v) is+ordinals is f v = fmap (v V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (length v) is {-# INLINE ordinals #-}
src/GHC/Generics/Lens.hs view
@@ -4,9 +4,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}-#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens@@ -64,17 +62,18 @@ -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens -- | Convert from the data type to its representation (or back) -- -- >>> "hello"^.generic.from generic :: String -- "hello"-generic :: Generic a => Iso' a (Rep a b)+generic :: (Generic a, Generic b) => Iso a b (Rep a g) (Rep b h) generic = iso Generic.from Generic.to {-# INLINE generic #-} -- | Convert from the data type to its representation (or back)-generic1 :: Generic1 f => Iso (f a) (f b) (Rep1 f a) (Rep1 f b)+generic1 :: (Generic1 f, Generic1 g) => Iso (f a) (g b) (Rep1 f a) (Rep1 g b) generic1 = iso from1 to1 {-# INLINE generic1 #-}
src/Language/Haskell/TH/Lens.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif@@ -61,14 +62,12 @@ -- ** FieldPat Lenses , fieldPatName , fieldPatPattern-#if MIN_VERSION_template_haskell(2,9,0) -- ** TySynEqn Lenses # if MIN_VERSION_template_haskell(2,15,0) , tySynEqnLHS # endif , tySynEqnPatterns , tySynEqnResult-#endif #if MIN_VERSION_template_haskell(2,11,0) -- ** InjectivityAnn Lenses , injectivityAnnOutput@@ -110,17 +109,13 @@ , _InstanceD , _SigD , _ForeignD-#if MIN_VERSION_template_haskell(2,8,0) , _InfixD-#endif , _PragmaD , _DataInstD , _NewtypeInstD , _TySynInstD-#if MIN_VERSION_template_haskell(2,9,0) , _ClosedTypeFamilyD , _RoleAnnotD-#endif #if MIN_VERSION_template_haskell(2,10,0) , _StandaloneDerivD , _DefaultSigD@@ -201,12 +196,9 @@ -- ** Pragma Prisms , _InlineP , _SpecialiseP-#if MIN_VERSION_template_haskell(2,8,0) , _SpecialiseInstP , _RuleP-#if MIN_VERSION_template_haskell(2,9,0) , _AnnP-#endif #if MIN_VERSION_template_haskell(2,10,0) , _LineP #endif@@ -227,13 +219,10 @@ -- ** RuleBndr Prisms , _RuleVar , _TypedRuleVar-#endif-#if MIN_VERSION_template_haskell(2,9,0) -- ** AnnTarget Prisms , _ModuleAnnotation , _TypeAnnotation , _ValueAnnotation-#endif -- ** FunDep Prisms TODO make a lens , _FunDep #if !(MIN_VERSION_template_haskell(2,13,0))@@ -257,18 +246,14 @@ , _UInfixE , _ParensE , _LamE-#if MIN_VERSION_template_haskell(2,8,0) , _LamCaseE-#endif , _TupE , _UnboxedTupE #if MIN_VERSION_template_haskell(2,12,0) , _UnboxedSumE #endif , _CondE-#if MIN_VERSION_template_haskell(2,8,0) , _MultiIfE-#endif , _LetE , _CaseE , _DoE@@ -352,9 +337,7 @@ , _SigT , _VarT , _ConT-#if MIN_VERSION_template_haskell(2,8,0) , _PromotedT-#endif , _TupleT , _UnboxedTupleT #if MIN_VERSION_template_haskell(2,12,0)@@ -365,14 +348,12 @@ , _EqualityT #endif , _ListT-#if MIN_VERSION_template_haskell(2,8,0) , _PromotedTupleT , _PromotedNilT , _PromotedConsT , _StarT , _ConstraintT , _LitT-#endif #if MIN_VERSION_template_haskell(2,11,0) , _InfixT , _UInfixT@@ -386,6 +367,14 @@ #if MIN_VERSION_template_haskell(2,16,0) , _ForallVisT #endif+#if MIN_VERSION_template_haskell(2,17,0)+ , _MulArrowT+#endif+#if MIN_VERSION_template_haskell(2,17,0)+ -- ** Specificity Prisms+ , _SpecifiedSpec+ , _InferredSpec+#endif -- ** TyVarBndr Prisms , _PlainTV , _KindedTV@@ -395,23 +384,19 @@ , _KindSig , _TyVarSig #endif-#if MIN_VERSION_template_haskell(2,8,0) -- ** TyLit Prisms , _NumTyLit , _StrTyLit-#endif #if !MIN_VERSION_template_haskell(2,10,0) -- ** Pred Prisms , _ClassP , _EqualP #endif-#if MIN_VERSION_template_haskell(2,9,0) -- ** Role Prisms , _NominalR , _RepresentationalR , _PhantomR , _InferR-#endif #if MIN_VERSION_template_haskell(2,12,0) -- ** DerivStrategy Prisms , _StockStrategy@@ -430,16 +415,17 @@ import Control.Lens.Prism import Control.Lens.Tuple import Control.Lens.Traversal-import Data.Map as Map hiding (toList,map)+import qualified Data.Map as Map+import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid-import Data.Set as Set hiding (toList,map)+import qualified Data.Set as Set+import Data.Set (Set) import Data.Set.Lens import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Syntax-#if MIN_VERSION_template_haskell(2,8,0) import Data.Word-#endif #if MIN_VERSION_template_haskell(2,15,0) import Control.Lens.Internal.TH (unfoldType) import Data.Foldable as F (foldl')@@ -451,9 +437,8 @@ -- | Extract (or modify) the 'Name' of something name :: Lens' t Name -instance HasName TyVarBndr where- name f (PlainTV n) = PlainTV <$> f n- name f (KindedTV n k) = (`KindedTV` k) <$> f n+instance HasName (TyVarBndr_ flag) where+ name = traverseTVName instance HasName Name where name = id@@ -478,11 +463,9 @@ name f (ExportF cc str n ty) = (\n' -> ExportF cc str n' ty) <$> f n -#if MIN_VERSION_template_haskell(2,8,0) instance HasName RuleBndr where name f (RuleVar n) = RuleVar <$> f n name f (TypedRuleVar n ty) = (`TypedRuleVar` ty) <$> f n-#endif #if MIN_VERSION_template_haskell(2,11,0) instance HasName TypeFamilyHead where@@ -518,20 +501,17 @@ types f (ImportF cc saf str n t) = ImportF cc saf str n <$> types f t types f (ExportF cc str n t) = ExportF cc str n <$> types f t -#if MIN_VERSION_template_haskell(2,9,0) instance HasTypes TySynEqn where #if MIN_VERSION_template_haskell(2,15,0) types f (TySynEqn mtvbs lhs rhs) = TySynEqn <$> traverse (traverse go) mtvbs <*> types f lhs <*> types f rhs where- go tvb@PlainTV{} = pure tvb- go (KindedTV n k) = KindedTV n <$> f k+ go = traverseTVKind f #else types f (TySynEqn lhss rhs) = TySynEqn <$> traverse (types f) lhss <*> types f rhs #endif-#endif instance HasTypes t => HasTypes [t] where types = traverse . types@@ -543,7 +523,7 @@ -- the 'Traversal' laws, when in doubt generate your names with 'newName'. typeVarsEx :: Set Name -> Traversal' t Name -instance HasTypeVars TyVarBndr where+instance HasTypeVars (TyVarBndr_ flag) where typeVarsEx s f b | s^.contains (b^.name) = pure b | otherwise = name f b@@ -563,13 +543,8 @@ typeVarsEx _ _ t@ListT{} = pure t typeVarsEx _ _ t@ArrowT{} = pure t typeVarsEx _ _ t@UnboxedTupleT{} = pure t-#if MIN_VERSION_template_haskell(2,8,0) typeVarsEx s f (SigT t k) = SigT <$> typeVarsEx s f t <*> typeVarsEx s f k-#else- typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t-#endif-#if MIN_VERSION_template_haskell(2,8,0) typeVarsEx _ _ t@PromotedT{} = pure t typeVarsEx _ _ t@PromotedTupleT{} = pure t typeVarsEx _ _ t@PromotedNilT{} = pure t@@ -577,7 +552,6 @@ typeVarsEx _ _ t@StarT{} = pure t typeVarsEx _ _ t@ConstraintT{} = pure t typeVarsEx _ _ t@LitT{} = pure t-#endif #if MIN_VERSION_template_haskell(2,10,0) typeVarsEx _ _ t@EqualityT{} = pure t #endif@@ -603,6 +577,9 @@ typeVarsEx s f (ForallVisT bs ty) = ForallVisT bs <$> typeVarsEx s' f ty where s' = s `Set.union` setOf typeVars bs #endif+#if MIN_VERSION_template_haskell(2,17,0)+ typeVarsEx _ _ t@MulArrowT{} = pure t+#endif #if !MIN_VERSION_template_haskell(2,10,0) instance HasTypeVars Pred where@@ -656,12 +633,7 @@ substType _ t@UnboxedTupleT{} = t substType m (AppT l r) = AppT (substType m l) (substType m r) substType m (SigT t k) = SigT (substType m t)-#if MIN_VERSION_template_haskell(2,8,0) (substType m k)-#else- k-#endif-#if MIN_VERSION_template_haskell(2,8,0) substType _ t@PromotedT{} = t substType _ t@PromotedTupleT{} = t substType _ t@PromotedNilT{} = t@@ -669,7 +641,6 @@ substType _ t@StarT{} = t substType _ t@ConstraintT{} = t substType _ t@LitT{} = t-#endif #if MIN_VERSION_template_haskell(2,10,0) substType _ t@EqualityT{} = t #endif@@ -690,6 +661,9 @@ substType m (ForallVisT bs ty) = ForallVisT bs (substType m' ty) where m' = foldrOf typeVars Map.delete m bs #endif+#if MIN_VERSION_template_haskell(2,17,0)+ substType _ t@MulArrowT{} = t+#endif instance SubstType t => SubstType [t] where substType = map . substType@@ -856,7 +830,7 @@ g (TypeFamilyHead n _ _ _ ) = n s (TypeFamilyHead _ tvbs rs ia) n = TypeFamilyHead n tvbs rs ia -typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndr]+typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndrUnit] typeFamilyHeadTyVarBndrs = lens g s where g (TypeFamilyHead _ tvbs _ _ ) = tvbs s (TypeFamilyHead n _ rs ia) tvbs = TypeFamilyHead n tvbs rs ia@@ -894,11 +868,7 @@ s (DerivClause mds _) = DerivClause mds #endif -#if MIN_VERSION_template_haskell(2,8,0) _ClassI :: Prism' Info (Dec, [InstanceDec])-#else-_ClassI :: Prism' Info (Dec, [Dec])-#endif _ClassI = prism' reviewer remitter where@@ -921,11 +891,7 @@ remitter (ClassOpI x y z) = Just (x, y, z) remitter _ = Nothing #else-# if MIN_VERSION_template_haskell(2,8,0) _ClassOpI :: Prism' Info (Name, Type, ParentName, Fixity)-# else-_ClassOpI :: Prism' Info (Name, Type, Name, Fixity)-# endif _ClassOpI = prism' reviewer remitter where@@ -954,11 +920,7 @@ remitter (FamilyI x y) = Just (x, y) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PrimTyConI :: Prism' Info (Name, Arity, Unlifted)-#else-_PrimTyConI :: Prism' Info (Name, Int, Bool)-#endif _PrimTyConI = prism' reviewer remitter where@@ -981,11 +943,7 @@ remitter (DataConI x y z) = Just (x, y, z) remitter _ = Nothing #else-# if MIN_VERSION_template_haskell(2,8,0) _DataConI :: Prism' Info (Name, Type, ParentName, Fixity)-# else-_DataConI :: Prism' Info (Name, Type, Name, Fixity)-# endif _DataConI = prism' reviewer remitter where@@ -1051,7 +1009,7 @@ remitter (ValD x y z) = Just (x, y, z) remitter _ = Nothing -_TySynD :: Prism' Dec (Name, [TyVarBndr], Type)+_TySynD :: Prism' Dec (Name, [TyVarBndrUnit], Type) _TySynD = prism' reviewer remitter where@@ -1059,7 +1017,7 @@ remitter (TySynD x y z) = Just (x, y, z) remitter _ = Nothing -_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndr], [FunDep], [Dec])+_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], [FunDep], [Dec]) _ClassD = prism' reviewer remitter where@@ -1135,7 +1093,6 @@ remitter (ForeignD x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _InfixD :: Prism' Dec (Fixity, Name) _InfixD = prism' reviewer remitter@@ -1143,7 +1100,6 @@ reviewer (x, y) = InfixD x y remitter (InfixD x y) = Just (x, y) remitter _ = Nothing-#endif _PragmaD :: Prism' Dec Pragma _PragmaD@@ -1167,7 +1123,7 @@ reviewer = TySynInstD remitter (TySynInstD x) = Just x remitter _ = Nothing-#elif MIN_VERSION_template_haskell(2,9,0)+#else _TySynInstD :: Prism' Dec (Name, TySynEqn) _TySynInstD = prism' reviewer remitter@@ -1175,17 +1131,8 @@ reviewer (x, y) = TySynInstD x y remitter (TySynInstD x y) = Just (x, y) remitter _ = Nothing-#else-_TySynInstD :: Prism' Dec (Name, [Type], Type)-_TySynInstD- = prism' reviewer remitter- where- reviewer (x, y, z) = TySynInstD x y z- remitter (TySynInstD x y z) = Just (x, y, z)- remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _RoleAnnotD :: Prism' Dec (Name, [Role]) _RoleAnnotD = prism' reviewer remitter@@ -1193,7 +1140,6 @@ reviewer (x, y) = RoleAnnotD x y remitter (RoleAnnotD x y) = Just (x, y) remitter _ = Nothing-#endif -- | -- @@@ -1236,13 +1182,13 @@ -- | -- @--- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndr'], 'Type', 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.15+--- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12 through 2.14--- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- template-haskell-2.11--- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions+-- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndrUnit'], 'Type', 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.15++-- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12 through 2.14+-- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- template-haskell-2.11+-- _DataInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0)-_DataInstD :: Prism' Dec (Cxt, Maybe [TyVarBndr], Type, Maybe Kind, [Con], [DerivClause])+_DataInstD :: Prism' Dec (Cxt, Maybe [TyVarBndrUnit], Type, Maybe Kind, [Con], [DerivClause]) _DataInstD = prism' reviewer remitter where@@ -1269,13 +1215,13 @@ -- | -- @--- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndr'], 'Type', 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.15+--- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12 through 2.14--- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- template-haskell-2.11--- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions+-- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Maybe' ['TyVarBndrUnit'], 'Type', 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.15++-- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12 through 2.14+-- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- template-haskell-2.11+-- _NewtypeInstD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0)-_NewtypeInstD :: Prism' Dec (Cxt, Maybe [TyVarBndr], Type, Maybe Kind, Con, [DerivClause])+_NewtypeInstD :: Prism' Dec (Cxt, Maybe [TyVarBndrUnit], Type, Maybe Kind, Con, [DerivClause]) _NewtypeInstD = prism' reviewer remitter where@@ -1308,8 +1254,8 @@ reviewer (x, y) = ClosedTypeFamilyD x y remitter (ClosedTypeFamilyD x y) = Just (x, y) remitter _ = Nothing-#elif MIN_VERSION_template_haskell(2,9,0)-_ClosedTypeFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind, [TySynEqn])+#else+_ClosedTypeFamilyD :: Prism' Dec (Name, [TyVarBndrUnit], Maybe Kind, [TySynEqn]) _ClosedTypeFamilyD = prism' reviewer remitter where@@ -1320,12 +1266,12 @@ -- | -- @--- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndr'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12+--- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- template-haskell-2.11--- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions+-- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12++-- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- template-haskell-2.11+-- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], ['Con'], ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,11,0)-_DataD :: DataPrism' [TyVarBndr] [Con]+_DataD :: DataPrism' [TyVarBndrUnit] [Con] _DataD = prism' reviewer remitter where@@ -1333,7 +1279,7 @@ remitter (DataD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else-_DataD :: Prism' Dec (Cxt, Name, [TyVarBndr], [Con], [Name])+_DataD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], [Con], [Name]) _DataD = prism' reviewer remitter where@@ -1344,12 +1290,12 @@ -- | -- @--- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndr'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12+--- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- template-haskell-2.11--- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions+-- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12++-- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- template-haskell-2.11+-- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Con', ['Name']) -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,11,0)-_NewtypeD :: DataPrism' [TyVarBndr] Con+_NewtypeD :: DataPrism' [TyVarBndrUnit] Con _NewtypeD = prism' reviewer remitter where@@ -1357,7 +1303,7 @@ remitter (NewtypeD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing #else-_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndr], Con, [Name])+_NewtypeD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], Con, [Name]) _NewtypeD = prism' reviewer remitter where@@ -1367,7 +1313,7 @@ #endif #if MIN_VERSION_template_haskell(2,11,0)-_DataFamilyD :: Prism' Dec (Name, [TyVarBndr], Maybe Kind)+_DataFamilyD :: Prism' Dec (Name, [TyVarBndrUnit], Maybe Kind) _DataFamilyD = prism' reviewer remitter where@@ -1383,7 +1329,7 @@ remitter (OpenTypeFamilyD x) = Just x remitter _ = Nothing #else-_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndr], Maybe Kind)+_FamilyD :: Prism' Dec (FamFlavour, Name, [TyVarBndrUnit], Maybe Kind) _FamilyD = prism' reviewer remitter where@@ -1529,7 +1475,7 @@ remitter (InfixC x y z) = Just (x, y, z) remitter _ = Nothing -_ForallC :: Prism' Con ([TyVarBndr], Cxt, Con)+_ForallC :: Prism' Con ([TyVarBndrSpec], Cxt, Con) _ForallC = prism' reviewer remitter where@@ -1735,12 +1681,6 @@ remitter Interruptible = Just () remitter _ = Nothing --- |--- @--- _InlineP :: 'Prism'' 'Pragma' ('Name', 'Inline', 'RuleMatch', 'Phases') -- template-haskell-2.8+--- _InlineP :: 'Prism'' 'Pragma' ('Name', 'Inline') -- Earlier versions--- @-#if MIN_VERSION_template_haskell(2,8,0) _InlineP :: Prism' Pragma (Name, Inline, RuleMatch, Phases) _InlineP = prism' reviewer remitter@@ -1748,22 +1688,7 @@ reviewer (x, y, z, w) = InlineP x y z w remitter (InlineP x y z w) = Just (x, y, z, w) remitter _ = Nothing-#else-_InlineP :: Prism' Pragma (Name, InlineSpec)-_InlineP- = prism' reviewer remitter- where- reviewer (x, y) = InlineP x y- remitter (InlineP x y) = Just (x, y)- remitter _ = Nothing-#endif --- |--- @--- _SpecialiseP :: 'Prism'' 'Pragma' ('Name', 'Type', 'Maybe' 'Inline', 'Phases') -- template-haskell-2.8+--- _SpecialiseP :: 'Prism'' 'Pragma' ('Name', 'Type', 'Maybe' 'InlineSpec') -- Earlier versions--- @-#if MIN_VERSION_template_haskell(2,8,0) _SpecialiseP :: Prism' Pragma (Name, Type, Maybe Inline, Phases) _SpecialiseP = prism' reviewer remitter@@ -1771,19 +1696,9 @@ reviewer (x, y, z, w) = SpecialiseP x y z w remitter (SpecialiseP x y z w) = Just (x, y, z, w) remitter _ = Nothing-#else-_SpecialiseP :: Prism' Pragma (Name, Type, Maybe InlineSpec)-_SpecialiseP- = prism' reviewer remitter- where- reviewer (x, y, z) = SpecialiseP x y z- remitter (SpecialiseP x y z) = Just (x, y, z)- remitter _ = Nothing-#endif -- TODO add lenses for InlineSpec -#if MIN_VERSION_template_haskell(2,8,0) _SpecialiseInstP :: Prism' Pragma Type _SpecialiseInstP = prism' reviewer remitter@@ -1794,11 +1709,11 @@ -- | -- @--- _RuleP :: 'Prism'' 'Pragma' ('String', 'Maybe' ['TyVarBndr'], ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- template-haskell-2.15+--- _RuleP :: 'Prism'' 'Pragma' ('String', ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- Earlier versions+-- _RuleP :: 'Prism'' 'Pragma' ('String', 'Maybe' ['TyVarBndrUnit'], ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- template-haskell-2.15++-- _RuleP :: 'Prism'' 'Pragma' ('String', ['RuleBndr'], 'Exp', 'Exp', 'Phases') -- Earlier versions -- @ #if MIN_VERSION_template_haskell(2,15,0)-_RuleP :: Prism' Pragma (String, Maybe [TyVarBndr], [RuleBndr], Exp, Exp, Phases)+_RuleP :: Prism' Pragma (String, Maybe [TyVarBndrUnit], [RuleBndr], Exp, Exp, Phases) _RuleP = prism' reviewer remitter where@@ -1815,7 +1730,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _AnnP :: Prism' Pragma (AnnTarget, Exp) _AnnP = prism' reviewer remitter@@ -1823,7 +1737,6 @@ reviewer (x, y) = AnnP x y remitter (AnnP x y) = Just (x, y) remitter _ = Nothing-#endif #if MIN_VERSION_template_haskell(2,10,0) _LineP :: Prism' Pragma (Int, String)@@ -1924,9 +1837,7 @@ reviewer (x, y) = TypedRuleVar x y remitter (TypedRuleVar x y) = Just (x, y) remitter _ = Nothing-#endif -#if MIN_VERSION_template_haskell(2,9,0) _ModuleAnnotation :: Prism' AnnTarget () _ModuleAnnotation = prism' reviewer remitter@@ -1950,7 +1861,6 @@ reviewer = ValueAnnotation remitter (ValueAnnotation x) = Just x remitter _ = Nothing-#endif _FunDep :: Iso' FunDep ([Name], [Name]) _FunDep@@ -1994,7 +1904,7 @@ tySynEqnResult = lens g s where g (TySynEqn _ _ rhs) = rhs s (TySynEqn mtvbs lhs _) = TySynEqn mtvbs lhs-#elif MIN_VERSION_template_haskell(2,9,0)+#else tySynEqnPatterns :: Lens' TySynEqn [Type] tySynEqnPatterns = lens g s where g (TySynEqn xs _) = xs@@ -2104,7 +2014,6 @@ remitter (LamE x y) = Just (x, y) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _LamCaseE :: Prism' Exp [Match] _LamCaseE = prism' reviewer remitter@@ -2112,7 +2021,6 @@ reviewer = LamCaseE remitter (LamCaseE x) = Just x remitter _ = Nothing-#endif -- | -- @@@ -2166,7 +2074,6 @@ remitter (CondE x y z) = Just (x, y, z) remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _MultiIfE :: Prism' Exp [(Guard, Exp)] _MultiIfE = prism' reviewer remitter@@ -2174,7 +2081,6 @@ reviewer = MultiIfE remitter (MultiIfE x) = Just x remitter _ = Nothing-#endif _LetE :: Prism' Exp ([Dec], Exp) _LetE@@ -2192,6 +2098,20 @@ remitter (CaseE x y) = Just (x, y) remitter _ = Nothing +-- |+-- @+-- _DoE :: 'Prism'' 'Exp' ('Maybe' 'ModName', ['Stmt']) -- template-haskell-2.17++-- _DoE :: 'Prism'' 'Exp' ['Stmt'] -- Earlier versions+-- @+# if MIN_VERSION_template_haskell(2,17,0)+_DoE :: Prism' Exp (Maybe ModName, [Stmt])+_DoE+ = prism' reviewer remitter+ where+ reviewer (x, y) = DoE x y+ remitter (DoE x y) = Just (x, y)+ remitter _ = Nothing+# else _DoE :: Prism' Exp [Stmt] _DoE = prism' reviewer remitter@@ -2199,6 +2119,7 @@ reviewer = DoE remitter (DoE x) = Just x remitter _ = Nothing+# endif _CompE :: Prism' Exp [Stmt] _CompE@@ -2279,6 +2200,20 @@ #endif #if MIN_VERSION_template_haskell(2,15,0)+-- |+-- @+-- _MDoE :: 'Prism'' 'Exp' ('Maybe' 'ModName', ['Stmt']) -- template-haskell-2.17++-- _MDoE :: 'Prism'' 'Exp' ['Stmt'] -- Earlier versions+-- @+# if MIN_VERSION_template_haskell(2,17,0)+_MDoE :: Prism' Exp (Maybe ModName, [Stmt])+_MDoE+ = prism' reviewer remitter+ where+ reviewer (x, y) = MDoE x y+ remitter (MDoE x y) = Just (x, y)+ remitter _ = Nothing+# else _MDoE :: Prism' Exp [Stmt] _MDoE = prism' reviewer remitter@@ -2286,6 +2221,7 @@ reviewer = MDoE remitter (MDoE x) = Just x remitter _ = Nothing+# endif _ImplicitParamVarE :: Prism' Exp String _ImplicitParamVarE@@ -2466,7 +2402,6 @@ remitter (DoublePrimL x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _StringPrimL :: Prism' Lit [Word8] _StringPrimL = prism' reviewer remitter@@ -2474,15 +2409,6 @@ reviewer = StringPrimL remitter (StringPrimL x) = Just x remitter _ = Nothing-#else-_StringPrimL :: Prism' Lit String-_StringPrimL- = prism' reviewer remitter- where- reviewer = StringPrimL- remitter (StringPrimL x) = Just x- remitter _ = Nothing-#endif #if MIN_VERSION_template_haskell(2,11,0) _CharPrimL :: Prism' Lit Char@@ -2642,7 +2568,7 @@ remitter (ViewP x y) = Just (x, y) remitter _ = Nothing -_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type)+_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter where@@ -2682,7 +2608,6 @@ remitter (ConT x) = Just x remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PromotedT :: Prism' Type Name _PromotedT = prism' reviewer remitter@@ -2690,7 +2615,6 @@ reviewer = PromotedT remitter (PromotedT x) = Just x remitter _ = Nothing-#endif _TupleT :: Prism' Type Int _TupleT@@ -2744,7 +2668,6 @@ remitter ListT = Just () remitter _ = Nothing -#if MIN_VERSION_template_haskell(2,8,0) _PromotedTupleT :: Prism' Type Int _PromotedTupleT = prism' reviewer remitter@@ -2792,7 +2715,6 @@ reviewer = LitT remitter (LitT x) = Just x remitter _ = Nothing-#endif #if MIN_VERSION_template_haskell(2,11,0) _InfixT :: Prism' Type (Type, Name, Type)@@ -2847,7 +2769,7 @@ #endif #if MIN_VERSION_template_haskell(2,16,0)-_ForallVisT :: Prism' Type ([TyVarBndr], Type)+_ForallVisT :: Prism' Type ([TyVarBndrUnit], Type) _ForallVisT = prism' reviewer remitter where@@ -2856,6 +2778,48 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,17,0)+_MulArrowT :: Prism' Type ()+_MulArrowT+ = prism' reviewer remitter+ where+ reviewer () = MulArrowT+ remitter MulArrowT = Just ()+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,17,0)+_SpecifiedSpec :: Prism' Specificity ()+_SpecifiedSpec+ = prism' reviewer remitter+ where+ reviewer () = SpecifiedSpec+ remitter SpecifiedSpec = Just ()+ remitter _ = Nothing++_InferredSpec :: Prism' Specificity ()+_InferredSpec+ = prism' reviewer remitter+ where+ reviewer () = InferredSpec+ remitter InferredSpec = Just ()+ remitter _ = Nothing+#endif++-- |+-- @+-- _PlainTV :: 'Prism'' ('TyVarBndr' flag) ('Name', flag) -- template-haskell-2.17++-- _PlainTV :: 'Prism'' 'TyVarBndr' 'Name' -- Earlier versions+-- @+#if MIN_VERSION_template_haskell(2,17,0)+_PlainTV :: Prism' (TyVarBndr flag) (Name, flag)+_PlainTV+ = prism' reviewer remitter+ where+ reviewer (x, y) = PlainTV x y+ remitter (PlainTV x y) = Just (x, y)+ remitter _ = Nothing+#else _PlainTV :: Prism' TyVarBndr Name _PlainTV = prism' reviewer remitter@@ -2863,7 +2827,22 @@ reviewer = PlainTV remitter (PlainTV x) = Just x remitter _ = Nothing+#endif +-- |+-- @+-- _KindedTV :: 'Prism'' ('TyVarBndr' flag) ('Name', flag, 'Kind') -- template-haskell-2.17++-- _KindedTV :: 'Prism'' 'TyVarBndr' ('Name', 'Kind') -- Earlier versions+-- @+#if MIN_VERSION_template_haskell(2,17,0)+_KindedTV :: Prism' (TyVarBndr flag) (Name, flag, Kind)+_KindedTV+ = prism' reviewer remitter+ where+ reviewer (x, y, z) = KindedTV x y z+ remitter (KindedTV x y z) = Just (x, y, z)+ remitter _ = Nothing+#else _KindedTV :: Prism' TyVarBndr (Name, Kind) _KindedTV = prism' reviewer remitter@@ -2871,6 +2850,7 @@ reviewer (x, y) = KindedTV x y remitter (KindedTV x y) = Just (x, y) remitter _ = Nothing+#endif #if MIN_VERSION_template_haskell(2,11,0) _NoSig :: Prism' FamilyResultSig ()@@ -2889,7 +2869,7 @@ remitter (KindSig x) = Just x remitter _ = Nothing -_TyVarSig :: Prism' FamilyResultSig TyVarBndr+_TyVarSig :: Prism' FamilyResultSig TyVarBndrUnit _TyVarSig = prism' reviewer remitter where@@ -2898,7 +2878,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,8,0) _NumTyLit :: Prism' TyLit Integer _NumTyLit = prism' reviewer remitter@@ -2914,7 +2893,6 @@ reviewer = StrTyLit remitter (StrTyLit x) = Just x remitter _ = Nothing-#endif #if !MIN_VERSION_template_haskell(2,10,0) _ClassP :: Prism' Pred (Name, [Type])@@ -2934,7 +2912,6 @@ remitter _ = Nothing #endif -#if MIN_VERSION_template_haskell(2,9,0) _NominalR :: Prism' Role () _NominalR = prism' reviewer remitter@@ -2966,7 +2943,6 @@ reviewer () = InferR remitter InferR = Just () remitter _ = Nothing-#endif #if MIN_VERSION_template_haskell(2,12,0) _StockStrategy :: Prism' DerivStrategy ()
src/Numeric/Lens.hs view
@@ -43,6 +43,7 @@ -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens -- >>> import Data.Monoid (Sum(..)) -- | This 'Prism' can be used to model the fact that every 'Integral'
src/System/FilePath/Lens.hs view
@@ -31,6 +31,9 @@ -- $setup -- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens+-- >>> import Control.Monad.State+-- >>> import System.FilePath ((</>)) {- NB: Be very careful if you are planning to modify the doctest output in this module! Path separators are OS-dependent (\\ with Windows, / with Posix),
+ tests/T917.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif+module T917 where++import Control.Lens+import Data.Proxy++#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806+import Data.Kind+#endif++-- Like Data.Functor.Const, but redfined to ensure that it is poly-kinded+-- across all versions of GHC, not just 8.0++newtype Constant a (b :: k) = Constant a++data T917OneA (a :: k -> *) (b :: k -> *) = MkT917OneA+data T917OneB a b = MkT917OneB (T917OneA a (Const b))+$(makePrisms ''T917OneB)++data T917TwoA (a :: k -> *) (b :: k -> *) = MkT917TwoA+data T917TwoB a b = MkT917TwoB (T917TwoA a (Const b))+$(makeClassyPrisms ''T917TwoB)++data family T917DataFam (a :: k)+data instance T917DataFam (a :: *) = MkT917DataFam { _unT917DataFam :: Proxy a }+$(makeLenses 'MkT917DataFam)++#if __GLASGOW_HASKELL__ >= 800+data T917GadtOne (a :: k) where+ MkT917GadtOne :: T917GadtOne (a :: *)+$(makePrisms ''T917GadtOne)++data T917GadtTwo (a :: k) where+ MkT917GadtTwo :: T917GadtTwo (a :: *)+$(makePrisms ''T917GadtTwo)+#endif
tests/doctests.hs view
@@ -7,19 +7,13 @@ -- Stability : provisional -- Portability : portable ----- This module provides doctests for a project based on the actual versions--- of the packages it was built with. It requires a corresponding Setup.lhs--- to be added to the project+-- This module exists to add dependencies ----------------------------------------------------------------------------- module Main where -import Build_doctests (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest- main :: IO () main = do- traverse_ putStrLn args- doctest args- where- args = flags ++ pkgs ++ module_sources+ putStrLn "This test-suite exists only to add dependencies"+ putStrLn "To run doctests: "+ putStrLn " cabal build all --enable-tests"+ putStrLn " cabal-docspec"
tests/hunit.hs view
@@ -2,11 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -#if __GLASGOW_HASKELL__ < 706--- Needed to avoid spurious warnings on GHC 7.4 due to an old TH bug-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-#endif- ----------------------------------------------------------------------------- -- | -- Module : Main (hunit)@@ -28,8 +23,9 @@ import Control.Lens import Control.Monad.State import Data.Char-import Data.List as List-import Data.Map as Map+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Map (Map) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif@@ -80,8 +76,8 @@ { _points = [ Point { _x = 0, _y = 0 } , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ]- , _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin")- , (Point { _x = 4, _y = 7 }, "Peak") ]+ , _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "Origin")+ , (Point { _x = 4, _y = 7 }, "Peak") ] , _box = Box { _low = Point { _x = 0, _y = 0 } , _high = Point { _x = 8, _y = 7 } } }@@ -254,18 +250,18 @@ case_modify_map_entry = (trig & labels.ix origin %~ List.map toUpper)- @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN")- , (Point { _x = 4, _y = 7 }, "Peak") ] }+ @?= trig { _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN")+ , (Point { _x = 4, _y = 7 }, "Peak") ] } case_insert_maybe_map_entry = (trig & labels.at (Point { _x = 8, _y = 0 }) .~ Just "Right")- @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin")- , (Point { _x = 4, _y = 7 }, "Peak")- , (Point { _x = 8, _y = 0 }, "Right") ] }+ @?= trig { _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "Origin")+ , (Point { _x = 4, _y = 7 }, "Peak")+ , (Point { _x = 8, _y = 0 }, "Right") ] } case_delete_maybe_map_entry = (trig & labels.at origin .~ Nothing)- @?= trig { _labels = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] }+ @?= trig { _labels = Map.fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } case_read_list_entry = (trig ^? points.element 0)
tests/properties.hs view
@@ -6,12 +6,10 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-}-#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Main (properties)@@ -36,9 +34,7 @@ import Data.Char (isAlphaNum, isAscii, toUpper) import Data.Text.Strict.Lens import Data.List.Lens-#if __GLASGOW_HASKELL__ >= 708 import GHC.Exts (Constraint)-#endif import Numeric (showHex, showOct, showSigned) import Numeric.Lens import Control.Lens.Properties (isIso, isLens, isPrism, isSetter, isTraversal)@@ -114,15 +110,12 @@ isValidChar c = isAscii c && isAlphaNum c -- Things that should typecheck but that we don't need to run-#if __GLASGOW_HASKELL__ >= 708 data Foo (a :: Constraint) (b :: Constraint) where Foo :: Foo (Num Int) b sampleExtremePoly :: Equality s t a b -> Foo a (Functor b) -> Foo s (Functor t) sampleExtremePoly f foo = f foo-#endif -#if __GLASGOW_HASKELL__ >= 706 samplePolyEquality :: Equality Monad Identity Monad Identity samplePolyEquality f = f @@ -134,13 +127,7 @@ forall KVS(k1 k2) (s :: k1) (t :: k2) (a :: k1) (b :: k2) . Equality s t a b -> AnEquality s t a b equalityAnEqualityPoly f = f-#else-lessSimple :: Equality a b a b-lessSimple f = f -equalityAnEquality :: Equality s t a b -> AnEquality s t a b-equalityAnEquality f = f-#endif equalityIso :: Equality s t a b -> Iso s t a b equalityIso f = f
tests/templates.hs view
@@ -27,6 +27,7 @@ import Control.Lens -- import Test.QuickCheck (quickCheck) import T799 ()+import T917 () data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar@@ -312,7 +313,6 @@ data family Family a b c -#if __GLASGOW_HASKELL >= 706 declareLenses [d| data instance Family Int (a, b) a = FamilyInt { fm0 :: (b, a), fm1 :: Int } |]@@ -323,8 +323,6 @@ checkFm1 :: Lens' (Family Int (a, b) a) Int checkFm1 = fm1 -#endif- class Class a where data Associated a method :: a -> Int@@ -342,7 +340,6 @@ checkMochi :: Iso' (Associated Int) Double checkMochi = mochi -#if __GLASGOW_HASKELL__ >= 706 declareFields [d| data DeclaredFields f a = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int }@@ -367,7 +364,6 @@ checkC0' :: Traversal' (DeclaredFields f a) String checkC0' = c0-#endif declareFields [d| data Aardvark = Aardvark { aardvarkAlbatross :: Int }
− travis/cabal-apt-install
@@ -1,22 +0,0 @@-#! /bin/bash-set -eu--APT="sudo apt-get -q -y"-CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall"--$APT update-$APT install dctrl-tools--# Find potential system packages to satisfy cabal dependencies-deps()-{- local M='^\([^ ]\+\)-[0-9.]\+ (.*$'- local G=' -o ( -FPackage -X libghc-\L\1\E-dev )'- local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \- | sed -ne "s/$M/$G/p" | sort -u)"- grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u-}--$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special-$CABAL_INSTALL_DEPS --constraint='hlint installed' "$@" # Install the rest via Hackage-
− travis/config
@@ -1,16 +0,0 @@--- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix------ This is particularly useful for travis-ci to get it to stop complaining--- about a broken build when everything is still correct on our end.------ This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead------ To enable this, uncomment the before_script in .travis.yml--remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive-remote-repo-cache: ~/.cabal/packages-world-file: ~/.cabal/world-build-summary: ~/.cabal/logs/build.log-remote-build-reporting: anonymous-install-dirs user-install-dirs global