bifunctors 5.5.7 → 5.5.8
raw patch · 11 files changed
+597/−436 lines, 11 filesdep ~template-haskelldep ~th-abstractionPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell, th-abstraction
API changes (from Hackage documentation)
Files
- .travis.yml +49/−84
- CHANGELOG.markdown +8/−0
- bifunctors.cabal +10/−6
- old-src/ghc709/Data/Bifunctor.hs +0/−8
- old-src/ghc801/Data/Bifoldable.hs +0/−7
- old-src/ghc801/Data/Bitraversable.hs +0/−7
- src/Data/Biapplicative.hs +1/−8
- src/Data/Bifunctor/Biap.hs +0/−5
- src/Data/Bifunctor/TH.hs +449/−262
- src/Data/Bifunctor/TH/Internal.hs +51/−49
- tests/BifunctorSpec.hs +29/−0
.travis.yml view
@@ -2,9 +2,13 @@ # # 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.9.20191126+# version: 0.10 # version: ~> 1.0 language: c@@ -19,7 +23,7 @@ - irc.freenode.org#haskell-lens skip_join: true template:- - "\"\\x0313bifunctors\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\""+ - "\x0313bifunctors\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" cache: directories: - $HOME/.cabal/packages@@ -37,49 +41,44 @@ 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.0"]}}+ 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"]}} os: linux- - compiler: ghc-8.8.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.8.1","cabal-install-3.0"]}}+ - 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} 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.0"]}}+ 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"]}} os: linux - compiler: ghc-7.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-7.2.2","cabal-install-3.0"]}}+ 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.2.2","cabal-install-3.2"]}} os: linux - compiler: ghc-7.0.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.0.4","cabal-install-3.0"]}}- os: linux- - compiler: ghc-head- 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-head","cabal-install-head"]}}+ 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.0.4","cabal-install-3.2"]}} os: linux allow_failures:- - compiler: ghc-head - compiler: ghc-7.0.4 - compiler: ghc-7.2.2- - compiler: ghc-8.10.1 before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC"@@ -92,69 +91,31 @@ - TOP=$(pwd) - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - echo $HCNUMVER- - CABAL="$CABAL -vnormal+nowrap+markoutput"+ - CABAL="$CABAL -vnormal+nowrap" - set -o pipefail- - |- echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk- echo 'BEGIN { state = "output"; }' >> .colorful.awk- echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk- echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk- echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk- echo ' if (state == "cabal") {' >> .colorful.awk- echo ' print blue($0)' >> .colorful.awk- echo ' } else {' >> .colorful.awk- echo ' print $0' >> .colorful.awk- echo ' }' >> .colorful.awk- echo '}' >> .colorful.awk- - cat .colorful.awk- - |- color_cabal_output () {- awk -f $TOP/.colorful.awk- }- - echo text | color_cabal_output-install:- - ${CABAL} --version- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - HEADHACKAGE=false- - if [ $HCNUMVER -ge 81000 ] ; then HEADHACKAGE=true ; fi - 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- echo " secure: True" >> $CABALHOME/config- echo " key-threshold: 3" >> $CABALHOME/config- echo " root-keys:" >> $CABALHOME/config- echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config- echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config- echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config- echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config- echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config- - |- if $HEADHACKAGE; then- echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config- echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config- echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config- echo " secure: True" >> $CABALHOME/config- echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config- echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config- echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config- echo " key-threshold: 3" >> $CABALHOME/config- fi+ 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@@ -166,19 +127,21 @@ - touch cabal.project - | echo "packages: ." >> cabal.project+ - if [ $HCNUMVER -ge 80200 ] ; then echo 'package bifunctors' >> 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 -- '^(bifunctors)$' || 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- - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze- - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output+ - 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 | color_cabal_output+ - ${CABAL} v2-sdist all # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false@@ -190,19 +153,21 @@ - touch cabal.project - | echo "packages: ${PKGDIR_bifunctors}" >> cabal.project+ - if [ $HCNUMVER -ge 80200 ] ; then echo 'package bifunctors' >> 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 -- '^(bifunctors)$' || 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 | color_cabal_output+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all # Testing...- - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output+ - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all # cabal check... - (cd ${PKGDIR_bifunctors} && ${CABAL} -vnormal check) # haddock...- - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output+ - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all -# REGENDATA ("0.9.20191126",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"])+# REGENDATA ("0.10",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) # EOF
CHANGELOG.markdown view
@@ -1,3 +1,11 @@+5.5.8 [2020.10.01]+------------------+* Fix a bug in which `deriveBifunctor` would fail on sufficiently complex uses+ of rank-n types in constructor fields.+* Fix a bug in which `deriveBiunctor` and related functions would needlessly+ reject data types whose two last type parameters appear as oversaturated+ arguments to a type family.+ 5.5.7 [2020.01.29] ------------------ * Add `Data.Bifunctor.Biap`.
bifunctors.cabal view
@@ -1,8 +1,8 @@ name: bifunctors category: Data, Functors-version: 5.5.7+version: 5.5.8 license: BSD3-cabal-version: >= 1.8+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -23,7 +23,7 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.1+ , GHC == 8.8.3 , GHC == 8.10.1 extra-source-files: .travis.yml@@ -60,8 +60,8 @@ base-orphans >= 0.5.2 && < 1, comonad >= 4 && < 6, containers >= 0.1 && < 0.7,- template-haskell >= 2.4 && < 2.17,- th-abstraction >= 0.3 && < 0.4,+ template-haskell >= 2.4 && < 2.18,+ th-abstraction >= 0.4 && < 0.5, transformers >= 0.2 && < 0.6 if !impl(ghc > 8.2)@@ -74,7 +74,7 @@ build-depends: tagged >= 0.7.3 && < 1 if flag(semigroups) && !impl(ghc >= 8.0)- build-depends: semigroups >= 0.8.3.1 && < 1+ build-depends: semigroups >= 0.16.2 && < 1 if impl(ghc<7.9) hs-source-dirs: old-src/ghc709@@ -110,6 +110,7 @@ Paths_bifunctors ghc-options: -Wall+ default-language: Haskell2010 test-suite bifunctors-spec@@ -118,6 +119,9 @@ main-is: Spec.hs other-modules: BifunctorSpec ghc-options: -Wall+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type+ default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover >= 1.8 build-depends: base >= 4 && < 5,
old-src/ghc709/Data/Bifunctor.hs view
@@ -8,9 +8,6 @@ {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett@@ -33,10 +30,7 @@ import Control.Applicative import Data.Functor.Constant--#if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup-#endif #ifdef MIN_VERSION_tagged import Data.Tagged@@ -116,10 +110,8 @@ bimap f g ~(a, b) = (f a, g b) {-# INLINE bimap #-} -#if MIN_VERSION_semigroups(0,16,2) instance Bifunctor Arg where bimap f g (Arg a b) = Arg (f a) (g b)-#endif instance Bifunctor ((,,) x) where bimap f g ~(x, a, b) = (x, f a, g b)
old-src/ghc801/Data/Bifoldable.hs view
@@ -7,9 +7,6 @@ {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett@@ -68,9 +65,7 @@ import Unsafe.Coerce #endif -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) import Data.Semigroup (Arg(..))-#endif #ifdef MIN_VERSION_tagged import Data.Tagged@@ -159,10 +154,8 @@ deriving instance Typeable Bifoldable #endif -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Bifoldable Arg where bifoldMap f g (Arg a b) = f a `mappend` g b-#endif instance Bifoldable (,) where bifoldMap f g ~(a, b) = f a `mappend` g b
old-src/ghc801/Data/Bitraversable.hs view
@@ -7,9 +7,6 @@ {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett@@ -51,9 +48,7 @@ import Data.Monoid #endif -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) import Data.Semigroup (Arg(..))-#endif #ifdef MIN_VERSION_tagged import Data.Tagged@@ -185,10 +180,8 @@ deriving instance Typeable Bitraversable #endif -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Bitraversable Arg where bitraverse f g (Arg a b) = Arg <$> f a <*> g b-#endif instance Bitraversable (,) where bitraverse f g ~(a, b) = (,) <$> f a <*> g b
src/Data/Biapplicative.hs view
@@ -7,9 +7,6 @@ {-# LANGUAGE Trustworthy #-} #endif -#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett@@ -42,9 +39,7 @@ import Data.Traversable (Traversable (traverse)) #endif -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) import Data.Semigroup (Arg(..))-#endif #ifdef MIN_VERSION_tagged import Data.Tagged@@ -178,7 +173,7 @@ go (Map f x) (Map g y) = bimap f g (go x y) go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys #if MIN_VERSION_base(4,10,0)- go (LiftA2 f xs ys) (LiftA2 g zs ws) = bimap f g (go xs zs) <<*>> go ys ws+ go (LiftA2 f xs ys) (LiftA2 g zs ws) = biliftA2 f g (go xs zs) (go ys ws) #endif go (One x) (One _) = p x go _ _ = impossibleError@@ -278,7 +273,6 @@ biliftA2 f g (x, y) (a, b) = (f x a, g y b) {-# INLINE biliftA2 #-} -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Biapplicative Arg where bipure = Arg {-# INLINE bipure #-}@@ -286,7 +280,6 @@ {-# INLINE (<<*>>) #-} biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b) {-# INLINE biliftA2 #-}-#endif instance Monoid x => Biapplicative ((,,) x) where bipure = (,,) mempty
src/Data/Bifunctor/Biap.hs view
@@ -11,9 +11,6 @@ #endif #include "bifunctors-common.h"-#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- |@@ -47,9 +44,7 @@ import Data.Traversable #endif -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) import qualified Data.Semigroup as S-#endif -- | Pointwise lifting of a class over two arguments, using -- 'Biapplicative'.
src/Data/Bifunctor/TH.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Unsafe #-}@@ -61,15 +62,15 @@ , defaultOptions ) where -import Control.Monad (guard, unless, when, zipWithM)+import Control.Monad (guard, unless, when) import Data.Bifunctor.TH.Internal-import Data.Either (rights) import Data.List-import qualified Data.Map as Map (fromList, keys, lookup, size)+import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size) import Data.Maybe import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax@@ -400,15 +401,15 @@ -- All constructors must be from the same type. makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp makeBiFunForCons biFun opts _parentName instTys cons = do- argNames <- mapM newName $ catMaybes [ Just "f"- , Just "g"- , guard (biFun == Bifoldr) >> Just "z"- , Just "value"- ]- let ([map1, map2], others) = splitAt 2 argNames- z = head others -- If we're deriving bifoldr, this will be well defined- -- and useful. Otherwise, it'll be ignored.- value = last others+ map1 <- newName "f"+ map2 <- newName "g"+ z <- newName "z" -- Only used for deriving bifoldr+ value <- newName "value"+ let argNames = catMaybes [ Just map1+ , Just map2+ , guard (biFun == Bifoldr) >> Just z+ , Just value+ ] lastTyVars = map varTToName $ drop (length instTys - 2) instTys tvMap = Map.fromList $ zip lastTyVars [map1, map2] lamE (map varP argNames)@@ -459,140 +460,178 @@ coerce = varE coerceValName `appE` varE value #endif --- | Generates a lambda expression for a single constructor.+-- | Generates a match for a single constructor. makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match makeBiFunForCon biFun z tvMap- (ConstructorInfo { constructorName = conName- , constructorContext = ctxt- , constructorFields = ts }) = do- ts' <- mapM resolveTypeSynonyms ts- argNames <- newNameList "_arg" $ length ts'- if (any (`predMentionsName` Map.keys tvMap) ctxt- || Map.size tvMap < 2)- && not (allowExQuant (biFunToClass biFun))- then existentialContextError conName- else makeBiFunForArgs biFun z tvMap conName ts' argNames+ con@(ConstructorInfo { constructorName = conName+ , constructorContext = ctxt }) = do+ when ((any (`predMentionsName` Map.keys tvMap) ctxt+ || Map.size tvMap < 2)+ && not (allowExQuant (biFunToClass biFun))) $+ existentialContextError conName+ case biFun of+ Bimap -> makeBimapMatch tvMap con+ Bifoldr -> makeBifoldrMatch z tvMap con+ BifoldMap -> makeBifoldMapMatch tvMap con+ Bitraverse -> makeBitraverseMatch tvMap con --- | Generates a lambda expression for a single constructor's arguments.-makeBiFunForArgs :: BiFun- -> Name- -> TyVarMap- -> Name- -> [Type]- -> [Name]- -> Q Match-makeBiFunForArgs biFun z tvMap conName tys args =- match (conP conName $ map varP args)- (normalB $ biFunCombine biFun conName z args mappedArgs)- []+-- | Generates a match whose right-hand side implements @bimap@.+makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match+makeBimapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+ parts <- foldDataConArgs tvMap ft_bimap con+ match_for_con conName parts where- mappedArgs :: Q [Either Exp Exp]- mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args---- | Generates a lambda expression for a single argument of a constructor.--- The returned value is 'Right' if its type mentions one of the last two type--- parameters. Otherwise, it is 'Left'.-makeBiFunForArg :: BiFun- -> TyVarMap- -> Name- -> Type- -> Name- -> Q (Either Exp Exp)-makeBiFunForArg biFun tvMap conName ty tyExpName =- makeBiFunForType biFun tvMap conName True ty `appEitherE` varE tyExpName---- | Generates a lambda expression for a specific type. The returned value is--- 'Right' if its type mentions one of the last two type parameters. Otherwise,--- it is 'Left'.-makeBiFunForType :: BiFun- -> TyVarMap- -> Name- -> Bool- -> Type- -> Q (Either Exp Exp)-makeBiFunForType biFun tvMap conName covariant (VarT tyName) =- case Map.lookup tyName tvMap of- Just mapName -> fmap Right . varE $- if covariant- then mapName- else contravarianceError conName- Nothing -> fmap Left $ biFunTriv biFun-makeBiFunForType biFun tvMap conName covariant (SigT ty _) =- makeBiFunForType biFun tvMap conName covariant ty-makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) =- makeBiFunForType biFun tvMap conName covariant ty-makeBiFunForType biFun tvMap conName covariant ty =- let tyCon :: Type- tyArgs :: [Type]- tyCon:tyArgs = unapplyTy ty-- numLastArgs :: Int- numLastArgs = min 2 $ length tyArgs+ ft_bimap :: FFoldType (Exp -> Q Exp)+ ft_bimap = FT { ft_triv = return+ , ft_var = \v x -> return $ VarE (tvMap Map.! v) `AppE` x+ , ft_fun = \g h x -> mkSimpleLam $ \b -> do+ gg <- g b+ h $ x `AppE` gg+ , ft_tup = mkSimpleTupleCase match_for_con+ , ft_ty_app = \argGs x -> do+ let inspect :: (Type, Exp -> Q Exp) -> Q Exp+ inspect (argTy, g)+ -- If the argument type is a bare occurrence of one+ -- of the data type's last type variables, then we+ -- can generate more efficient code.+ -- This was inspired by GHC#17880.+ | Just argVar <- varTToName_maybe argTy+ , Just f <- Map.lookup argVar tvMap+ = return $ VarE f+ | otherwise+ = mkSimpleLam g+ appsE $ varE (fmapArity (length argGs))+ : map inspect argGs+ ++ [return x]+ , ft_forall = \_ g x -> g x+ , ft_bad_app = \_ -> outOfPlaceTyVarError conName+ , ft_co_var = \_ _ -> contravarianceError conName+ } - lhsArgs, rhsArgs :: [Type]- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs+ -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...+ match_for_con :: Name -> [Exp -> Q Exp] -> Q Match+ match_for_con = mkSimpleConMatch $ \conName' xs ->+ appsE (conE conName':xs) -- Con x1 x2 .. - tyVarNames :: [Name]- tyVarNames = Map.keys tvMap+-- | Generates a match whose right-hand side implements @bifoldr@.+makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match+makeBifoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do+ parts <- foldDataConArgs tvMap ft_bifoldr con+ parts' <- sequence parts+ match_for_con (VarE z) conName parts'+ where+ -- The Bool is True if the type mentions of the last two type parameters,+ -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter+ -- out expressions that do not mention the last parameters by checking for+ -- False.+ ft_bifoldr :: FFoldType (Q (Bool, Exp))+ ft_bifoldr = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]+ ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z'+ return (False, lam)+ , ft_var = \v -> return (True, VarE $ tvMap Map.! v)+ , ft_tup = \t gs -> do+ gg <- sequence gs+ lam <- mkSimpleLam2 $ \x z' ->+ mkSimpleTupleCase (match_for_con z') t gg x+ return (True, lam)+ , ft_ty_app = \gs -> do+ lam <- mkSimpleLam2 $ \x z' ->+ appsE $ varE (foldrArity (length gs))+ : map (\(_, hs) -> fmap snd hs) gs+ ++ map return [z', x]+ return (True, lam)+ , ft_forall = \_ g -> g+ , ft_co_var = \_ -> contravarianceError conName+ , ft_fun = \_ _ -> noFunctionsError conName+ , ft_bad_app = outOfPlaceTyVarError conName+ } - mentionsTyArgs :: Bool- mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs+ match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match+ match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldr xs+ where+ -- g1 v1 (g2 v2 (.. z))+ mkBifoldr :: [Exp] -> Exp+ mkBifoldr = foldr AppE zExp - makeBiFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int- -> Q (Either Exp Exp)- makeBiFunTuple mkTupP mkTupleDataName n = do- args <- mapM newName $ catMaybes [ Just "x"- , guard (biFun == Bifoldr) >> Just "z"- ]- xs <- newNameList "_tup" n+-- | Generates a match whose right-hand side implements @bifoldMap@.+makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match+makeBifoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+ parts <- foldDataConArgs tvMap ft_bifoldMap con+ parts' <- sequence parts+ match_for_con conName parts'+ where+ -- The Bool is True if the type mentions of the last two type parameters,+ -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter+ -- out expressions that do not mention the last parameters by checking for+ -- False.+ ft_bifoldMap :: FFoldType (Q (Bool, Exp))+ ft_bifoldMap = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]+ ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName+ return (False, lam)+ , ft_var = \v -> return (True, VarE $ tvMap Map.! v)+ , ft_tup = \t gs -> do+ gg <- sequence gs+ lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg+ return (True, lam)+ , ft_ty_app = \gs -> do+ e <- appsE $ varE (foldMapArity (length gs))+ : map (\(_, hs) -> fmap snd hs) gs+ return (True, e)+ , ft_forall = \_ g -> g+ , ft_co_var = \_ -> contravarianceError conName+ , ft_fun = \_ _ -> noFunctionsError conName+ , ft_bad_app = outOfPlaceTyVarError conName+ } - let x = head args- z = last args- fmap Right $ lamE (map varP args) $ caseE (varE x)- [ match (mkTupP $ map varP xs)- (normalB $ biFunCombine biFun- (mkTupleDataName n)- z- xs- (zipWithM makeBiFunTupleField tyArgs xs)- )- []- ]+ match_for_con :: Name -> [(Bool, Exp)] -> Q Match+ match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldMap xs+ where+ -- mappend v1 (mappend v2 ..)+ mkBifoldMap :: [Exp] -> Exp+ mkBifoldMap [] = VarE memptyValName+ mkBifoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es - makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)- makeBiFunTupleField fieldTy fieldName =- makeBiFunForType biFun tvMap conName covariant fieldTy- `appEitherE` varE fieldName+-- | Generates a match whose right-hand side implements @bitraverse@.+makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match+makeBitraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+ parts <- foldDataConArgs tvMap ft_bitrav con+ parts' <- sequence parts+ match_for_con conName parts'+ where+ -- The Bool is True if the type mentions of the last two type parameters,+ -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter+ -- out expressions that do not mention the last parameters by checking for+ -- False.+ ft_bitrav :: FFoldType (Q (Bool, Exp))+ ft_bitrav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]+ ft_triv = return (False, VarE pureValName)+ , ft_var = \v -> return (True, VarE $ tvMap Map.! v)+ , ft_tup = \t gs -> do+ gg <- sequence gs+ lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg+ return (True, lam)+ , ft_ty_app = \gs -> do+ e <- appsE $ varE (traverseArity (length gs))+ : map (\(_, hs) -> fmap snd hs) gs+ return (True, e)+ , ft_forall = \_ g -> g+ , ft_co_var = \_ -> contravarianceError conName+ , ft_fun = \_ _ -> noFunctionsError conName+ , ft_bad_app = outOfPlaceTyVarError conName+ } - in case tyCon of- ArrowT- | not (allowFunTys (biFunToClass biFun)) -> noFunctionsError conName- | mentionsTyArgs, [argTy, resTy] <- tyArgs ->- do x <- newName "x"- b <- newName "b"- fmap Right . lamE [varP x, varP b] $- covBiFun covariant resTy `appE` (varE x `appE`- (covBiFun (not covariant) argTy `appE` varE b))- where- covBiFun :: Bool -> Type -> Q Exp- covBiFun cov = fmap fromEither . makeBiFunForType biFun tvMap conName cov-#if MIN_VERSION_template_haskell(2,6,0)- UnboxedTupleT n- | n > 0 && mentionsTyArgs -> makeBiFunTuple unboxedTupP unboxedTupleDataName n-#endif- TupleT n- | n > 0 && mentionsTyArgs -> makeBiFunTuple tupP tupleDataName n- _ -> do- itf <- isTyFamily tyCon- if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)- then outOfPlaceTyVarError conName- else if any (`mentionsName` tyVarNames) rhsArgs- then fmap Right . biFunApp biFun . appsE $- ( varE (fromJust $ biFunArity biFun numLastArgs)- : map (fmap fromEither . makeBiFunForType biFun tvMap conName covariant)- rhsArgs- )- else fmap Left $ biFunTriv biFun+ -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)+ -- (g2 a2) <*> ...+ match_for_con :: Name -> [(Bool, Exp)] -> Q Match+ match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs+ where+ -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..+ mkApCon :: Exp -> [Exp] -> Exp+ mkApCon conExp [] = VarE pureValName `AppE` conExp+ mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e+ mkApCon conExp (e1:e2:es) = foldl' appAp+ (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es+ where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation@@ -842,8 +881,8 @@ -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: BiClass -> Name -> a-derivingKindError biClass tyConName = error+derivingKindError :: BiClass -> Name -> Q a+derivingKindError biClass tyConName = fail . showString "Cannot derive well-kinded instance of form ‘" . showString className . showChar ' '@@ -861,8 +900,8 @@ -- | One of the last two type variables appeard in a contravariant position -- when deriving Bifoldable or Bitraversable.-contravarianceError :: Name -> a-contravarianceError conName = error+contravarianceError :: Name -> Q a+contravarianceError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must not use the last type variable(s) in a function argument"@@ -870,8 +909,8 @@ -- | A constructor has a function argument in a derived Bifoldable or Bitraversable -- instance.-noFunctionsError :: Name -> a-noFunctionsError conName = error+noFunctionsError :: Name -> Q a+noFunctionsError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must not contain function types"@@ -879,8 +918,8 @@ -- | The data type has a DatatypeContext which mentions one of the eta-reduced -- type variables.-datatypeContextError :: Name -> Type -> a-datatypeContextError dataName instanceType = error+datatypeContextError :: Name -> Type -> Q a+datatypeContextError dataName instanceType = fail . showString "Can't make a derived instance of ‘" . showString (pprint instanceType) . showString "‘:\n\tData type ‘"@@ -890,8 +929,8 @@ -- | The data type has an existential constraint which mentions one of the -- eta-reduced type variables.-existentialContextError :: Name -> a-existentialContextError conName = error+existentialContextError :: Name -> Q a+existentialContextError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must be truly polymorphic in the last argument(s) of the data type"@@ -899,8 +938,8 @@ -- | The data type mentions one of the n eta-reduced type variables in a place other -- than the last nth positions of a data type in a constructor's field.-outOfPlaceTyVarError :: Name -> a-outOfPlaceTyVarError conName = error+outOfPlaceTyVarError :: Name -> Q a+outOfPlaceTyVarError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must only use its last two type variable(s) within"@@ -909,8 +948,8 @@ -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet).-etaReductionError :: Type -> a-etaReductionError instanceType = error $+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType @@ -960,119 +999,32 @@ biClassConstraint biClass 2 = Just $ biClassName biClass biClassConstraint _ _ = Nothing -biFunArity :: BiFun -> Int -> Maybe Name-biFunArity Bimap 1 = Just fmapValName-biFunArity Bifoldr 1 = Just foldrValName-biFunArity BifoldMap 1 = Just foldMapValName-biFunArity Bitraverse 1 = Just traverseValName-biFunArity biFun 2 = Just $ biFunName biFun-biFunArity _ _ = Nothing--allowFunTys :: BiClass -> Bool-allowFunTys Bifunctor = True-allowFunTys _ = False--allowExQuant :: BiClass -> Bool-allowExQuant Bifoldable = True-allowExQuant _ = False---- See Trac #7436 for why explicit lambdas are used-biFunTriv :: BiFun -> Q Exp-biFunTriv Bimap = do- x <- newName "x"- lamE [varP x] $ varE x--- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem--- useless, but they do serve a purpose.--- See Note [biFunTriv for Bifoldable and Bitraversable]-biFunTriv Bifoldr = do- z <- newName "z"- lamE [wildP, varP z] $ varE z-biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName-biFunTriv Bitraverse = varE pureValName--biFunApp :: BiFun -> Q Exp -> Q Exp-biFunApp Bifoldr e = do- x <- newName "x"- z <- newName "z"- lamE [varP x, varP z] $ appsE [e, varE z, varE x]-biFunApp _ e = e--biFunCombine :: BiFun- -> Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-biFunCombine Bimap = bimapCombine-biFunCombine Bifoldr = bifoldrCombine-biFunCombine BifoldMap = bifoldMapCombine-biFunCombine Bitraverse = bitraverseCombine--bimapCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bimapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither)---- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since--- they filter out subexpressions whose types do not mention one of the last two--- type parameters. See--- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable--- for further discussion.--bifoldrCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bifoldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights)--bifoldMapCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bifoldMapCombine _ _ _ = fmap (go . rights)- where- go :: [Exp] -> Exp- go [] = VarE memptyValName- go es = foldr1 (AppE . AppE (VarE mappendValName)) es--bitraverseCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bitraverseCombine conName _ args essQ = do- ess <- essQ-- let argTysTyVarInfo :: [Bool]- argTysTyVarInfo = map isRight ess+fmapArity :: Int -> Name+fmapArity 1 = fmapValName+fmapArity 2 = bimapValName+fmapArity n = arityErr n - argsWithTyVar, argsWithoutTyVar :: [Name]- (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args+foldrArity :: Int -> Name+foldrArity 1 = foldrValName+foldrArity 2 = bifoldrValName+foldrArity n = arityErr n - conExpQ :: Q Exp- conExpQ- | null argsWithTyVar- = appsE (conE conName:map varE argsWithoutTyVar)- | otherwise = do- bs <- newNameList "b" $ length args- let bs' = filterByList argTysTyVarInfo bs- vars = filterByLists argTysTyVarInfo- (map varE bs) (map varE args)- lamE (map varP bs') (appsE (conE conName:vars))+foldMapArity :: Int -> Name+foldMapArity 1 = foldMapValName+foldMapArity 2 = bifoldMapValName+foldMapArity n = arityErr n - conExp <- conExpQ+traverseArity :: Int -> Name+traverseArity 1 = traverseValName+traverseArity 2 = bitraverseValName+traverseArity n = arityErr n - let go :: [Exp] -> Exp- go [] = VarE pureValName `AppE` conExp- go [e] = VarE fmapValName `AppE` conExp `AppE` e- go (e1:e2:es) = foldl' (\se1 se2 -> InfixE (Just se1) (VarE apValName) (Just se2))- (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es+arityErr :: Int -> a+arityErr n = error $ "Unsupported arity: " ++ show n - return . go . rights $ ess+allowExQuant :: BiClass -> Bool+allowExQuant Bifoldable = True+allowExQuant _ = False biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp biFunEmptyCase biFun z value =@@ -1104,11 +1056,11 @@ go Bitraverse = bitraverseE {--Note [biFunTriv for Bifoldable and Bitraversable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [ft_triv for Bifoldable and Bitraversable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose type does not mention one of the last two type parameters. From this, you might-think that we don't need to implement biFunTriv for bifoldr, bifoldMap, or+think that we don't need to implement ft_triv for bifoldr, bifoldMap, or bitraverse at all, but in fact we do need to. Imagine the following data type: data T a b = MkT a (T Int b)@@ -1118,6 +1070,241 @@ bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 -You need to fill in biFunTriv (\_ -> mempty) as the first argument to the recursive+You need to fill in bi_triv (\_ -> mempty) as the first argument to the recursive call to bifoldMap, since that is how the algorithm handles polymorphic recursion. -}++-------------------------------------------------------------------------------+-- Generic traversal for functor-like deriving+-------------------------------------------------------------------------------++-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.++data FFoldType a -- Describes how to fold over a Type in a functor like way+ = FT { ft_triv :: a+ -- ^ Does not contain variables+ , ft_var :: Name -> a+ -- ^ A bare variable+ , ft_co_var :: Name -> a+ -- ^ A bare variable, contravariantly+ , ft_fun :: a -> a -> a+ -- ^ Function type+ , ft_tup :: TupleSort -> [a] -> a+ -- ^ Tuple type. The [a] is the result of folding over the+ -- arguments of the tuple.+ , ft_ty_app :: [(Type, a)] -> a+ -- ^ Type app, variables only in last argument. The [(Type, a)]+ -- represents the last argument types. That is, they form the+ -- argument parts of @fun_ty arg_ty_1 ... arg_ty_n@.+ , ft_bad_app :: a+ -- ^ Type app, variable other than in last arguments+ , ft_forall :: [TyVarBndrSpec] -> a -> a+ -- ^ Forall type+ }++-- Note that in GHC, this function is pure. It must be monadic here since we:+--+-- (1) Expand type synonyms+-- (2) Detect type family applications+--+-- Which require reification in Template Haskell, but are pure in Core.+functorLikeTraverse :: forall a.+ TyVarMap -- ^ Variables to look for+ -> FFoldType a -- ^ How to fold+ -> Type -- ^ Type to process+ -> Q a+functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar+ , ft_co_var = caseCoVar, ft_fun = caseFun+ , ft_tup = caseTuple, ft_ty_app = caseTyApp+ , ft_bad_app = caseWrongArg, ft_forall = caseForAll })+ ty+ = do ty' <- resolveTypeSynonyms ty+ (res, _) <- go False ty'+ return res+ where+ go :: Bool -- Covariant or contravariant context+ -> Type+ -> Q (a, Bool) -- (result of type a, does type contain var)+ go co t@AppT{}+ | (ArrowT, [funArg, funRes]) <- unapplyTy t+ = do (funArgR, funArgC) <- go (not co) funArg+ (funResR, funResC) <- go co funRes+ if funArgC || funResC+ then return (caseFun funArgR funResR, True)+ else trivial+ go co t@AppT{} = do+ let (f, args) = unapplyTy t+ (_, fc) <- go co f+ (xrs, xcs) <- fmap unzip $ mapM (go co) args+ let numLastArgs, numFirstArgs :: Int+ numLastArgs = min 2 $ length args+ numFirstArgs = length args - numLastArgs++ tuple :: TupleSort -> Q (a, Bool)+ tuple tupSort = return (caseTuple tupSort xrs, True)++ wrongArg :: Q (a, Bool)+ wrongArg = return (caseWrongArg, True)++ case () of+ _ | not (or xcs)+ -> trivial -- Variable does not occur+ -- At this point we know that xrs, xcs is not empty,+ -- and at least one xr is True+ | TupleT len <- f+ -> tuple $ Boxed len+#if MIN_VERSION_template_haskell(2,6,0)+ | UnboxedTupleT len <- f+ -> tuple $ Unboxed len+#endif+ | fc || or (take numFirstArgs xcs)+ -> wrongArg -- T (..var..) ty_1 ... ty_n+ | otherwise -- T (..no var..) ty_1 ... ty_n+ -> do itf <- isInTypeFamilyApp tyVarNames f args+ if itf -- We can't decompose type families, so+ -- error if we encounter one here.+ then wrongArg+ else return ( caseTyApp $ drop numFirstArgs $ zip args xrs+ , True )+ go co (SigT t k) = do+ (_, kc) <- go_kind co k+ if kc+ then return (caseWrongArg, True)+ else go co t+ go co (VarT v)+ | Map.member v tvMap+ = return (if co then caseCoVar v else caseVar v, True)+ | otherwise+ = trivial+ go co (ForallT tvbs _ t) = do+ (tr, tc) <- go co t+ let tvbNames = map tvName tvbs+ if not tc || any (`elem` tvbNames) tyVarNames+ then trivial+ else return (caseForAll tvbs tr, True)+ go _ _ = trivial++ go_kind :: Bool+ -> Kind+ -> Q (a, Bool)+#if MIN_VERSION_template_haskell(2,9,0)+ go_kind = go+#else+ go_kind _ _ = trivial+#endif++ trivial :: Q (a, Bool)+ trivial = return (caseTrivial, False)++ tyVarNames :: [Name]+ tyVarNames = Map.keys tvMap++-- Fold over the arguments of a data constructor in a Functor-like way.+foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]+foldDataConArgs tvMap ft con = do+ fieldTys <- mapM resolveTypeSynonyms $ constructorFields con+ mapM foldArg fieldTys+ where+ foldArg :: Type -> Q a+ foldArg = functorLikeTraverse tvMap ft++-- Make a 'LamE' using a fresh variable.+mkSimpleLam :: (Exp -> Q Exp) -> Q Exp+mkSimpleLam lam = do+ n <- newName "n"+ body <- lam (VarE n)+ return $ LamE [VarP n] body++-- Make a 'LamE' using two fresh variables.+mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp+mkSimpleLam2 lam = do+ n1 <- newName "n1"+ n2 <- newName "n2"+ body <- lam (VarE n1) (VarE n2)+ return $ LamE [VarP n1, VarP n2] body++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConMatch fold conName insides@ produces a match clause in+-- which the LHS pattern-matches on @extraPats@, followed by a match on the+-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over+-- @conName@ and its arguments, applying an expression (from @insides@) to each+-- of the respective arguments of @conName@.+mkSimpleConMatch :: (Name -> [a] -> Q Exp)+ -> Name+ -> [Exp -> a]+ -> Q Match+mkSimpleConMatch fold conName insides = do+ varsNeeded <- newNameList "_arg" $ length insides+ let pat = ConP conName (map VarP varsNeeded)+ rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded)+ return $ Match pat (NormalB rhs) []++-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"+--+-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to+-- 'mkSimpleConMatch', with two key differences:+--+-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it+-- filters out the expressions corresponding to arguments whose types do not+-- mention the last type variable in a derived 'Foldable' or 'Traversable'+-- instance (i.e., those elements of @insides@ containing @False@).+--+-- 2. @fold@ takes an expression as its first argument instead of a+-- constructor name. This is because it uses a specialized+-- constructor function expression that only takes as many parameters as+-- there are argument types that mention the last type variable.+mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)+ -> Name+ -> [(Bool, Exp)]+ -> Q Match+mkSimpleConMatch2 fold conName insides = do+ varsNeeded <- newNameList "_arg" lengthInsides+ let pat = ConP conName (map VarP varsNeeded)+ -- Make sure to zip BEFORE invoking catMaybes. We want the variable+ -- indicies in each expression to match up with the argument indices+ -- in conExpr (defined below).+ exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v)+ else Nothing)+ insides varsNeeded+ -- An element of argTysTyVarInfo is True if the constructor argument+ -- with the same index has a type which mentions the last type+ -- variable.+ argTysTyVarInfo = map (\(m, _) -> m) insides+ (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded++ conExpQ+ | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar)+ | otherwise = do+ bs <- newNameList "b" lengthInsides+ let bs' = filterByList argTysTyVarInfo bs+ vars = filterByLists argTysTyVarInfo+ (map varE bs) (map varE varsNeeded)+ lamE (map varP bs') (appsE (conE conName:vars))++ conExp <- conExpQ+ rhs <- fold conExp exps+ return $ Match pat (NormalB rhs) []+ where+ lengthInsides = length insides++-- Indicates whether a tuple is boxed or unboxed, as well as its number of+-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)+-- corresponds to @Unboxed 3@.+data TupleSort+ = Boxed Int+#if MIN_VERSION_template_haskell(2,6,0)+ | Unboxed Int+#endif++-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"+mkSimpleTupleCase :: (Name -> [a] -> Q Match)+ -> TupleSort -> [a] -> Exp -> Q Exp+mkSimpleTupleCase matchForCon tupSort insides x = do+ let tupDataName = case tupSort of+ Boxed len -> tupleDataName len+#if MIN_VERSION_template_haskell(2,6,0)+ Unboxed len -> unboxedTupleDataName len+#endif+ m <- matchForCon tupDataName insides+ return $ CaseE x [m]
src/Data/Bifunctor/TH/Internal.hs view
@@ -15,7 +15,6 @@ -} module Data.Bifunctor.TH.Internal where -import Data.Bifunctor (bimap) import Data.Foldable (foldr') import Data.List import qualified Data.Map as Map (singleton)@@ -110,21 +109,6 @@ -- Assorted utilities ------------------------------------------------------------------------------- --- isRight and fromEither taken from the extra package (BSD3-licensed)---- | Test if an 'Either' value is the 'Right' constructor.--- Provided as standard with GHC 7.8 and above.-isRight :: Either l r -> Bool-isRight Right{} = True; isRight _ = False---- | Pull the value out of an 'Either' where both alternatives--- have the same type.------ > \x -> fromEither (Left x ) == x--- > \x -> fromEither (Right x) == x-fromEither :: Either a a -> a-fromEither = either id id- -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) -- | 'filterByList' takes a list of Bools and a list of some elements and@@ -166,15 +150,6 @@ go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs go trues falses _ _ = (reverse trues, reverse falses) --- | Apply an @Either Exp Exp@ expression to an 'Exp' expression,--- preserving the 'Either'-ness.-appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)-appEitherE e1Q e2Q = do- e2 <- e2Q- let e2' :: Exp -> Exp- e2' = (`AppE` e2)- bimap e2' e2' `fmap` e1Q- -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True@@ -276,24 +251,53 @@ isTyVar (SigT t _) = isTyVar t isTyVar _ = False --- | Is the given type a type family constructor (and not a data family constructor)?-isTyFamily :: Type -> Q Bool-isTyFamily (ConT n) = do- info <- reify n- return $ case info of+-- | Detect if a Name in a list of provided Names occurs as an argument to some+-- type family. This makes an effort to exclude /oversaturated/ arguments to+-- type families. For instance, if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool+isInTypeFamilyApp names tyFun tyArgs =+ case tyFun of+ ConT tcName -> go tcName+ _ -> return False+ where+ go :: Name -> Q Bool+ go tcName = do+ info <- reify tcName+ case info of #if MIN_VERSION_template_haskell(2,11,0)- FamilyI OpenTypeFamilyD{} _ -> True+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> withinFirstArgs bndrs #elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ _ _) _ -> True+ FamilyI (FamilyD TypeFam _ bndrs _) _+ -> withinFirstArgs bndrs #else- TyConI (FamilyD TypeFam _ _ _) -> True+ TyConI (FamilyD TypeFam _ bndrs _)+ -> withinFirstArgs bndrs #endif-#if MIN_VERSION_template_haskell(2,9,0)- FamilyI ClosedTypeFamilyD{} _ -> True++#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> withinFirstArgs bndrs+#elif MIN_VERSION_template_haskell(2,9,0)+ FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+ -> withinFirstArgs bndrs #endif- _ -> False-isTyFamily _ = return False + _ -> return False+ where+ withinFirstArgs :: [a] -> Q Bool+ withinFirstArgs bndrs =+ let firstArgs = take (length bndrs) tyArgs+ argFVs = freeVariables firstArgs+ in return $ any (`elem` argFVs) names+ -- | Are all of the items in a list (which have an ordering) distinct? -- -- This uses Set (as opposed to nub) for better asymptotic time complexity.@@ -347,14 +351,17 @@ -- @ -- [Either, Int, Char] -- @-unapplyTy :: Type -> [Type]-unapplyTy = reverse . go+unapplyTy :: Type -> (Type, [Type])+unapplyTy ty = go ty ty [] where- go :: Type -> [Type]- go (AppT t1 t2) = t2:go t1- go (SigT t _) = go t- go (ForallT _ _ t) = go t- go t = [t]+ go :: Type -> Type -> [Type] -> (Type, [Type])+ go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args)+ go origTy (SigT ty' _) args = go origTy ty' args+#if MIN_VERSION_template_haskell(2,11,0)+ go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args+ go origTy (ParensT ty') args = go origTy ty' args+#endif+ go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this: --@@ -463,11 +470,6 @@ unwrapMonadValName :: Name unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"--#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0))-starKindName :: Name-starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"-#endif #if MIN_VERSION_base(4,8,0) bifunctorTypeName :: Name
tests/BifunctorSpec.hs view
@@ -117,6 +117,15 @@ type role Empty2 nominal nominal #endif +data TyCon81 a b+ = TyCon81a (forall c. c -> (forall d. a -> d) -> a)+ | TyCon81b (Int -> forall c. c -> b)++type family F :: * -> * -> *+type instance F = Either++data TyCon82 a b = TyCon82 (F a b)+ -- Data families data family StrangeFam x y z@@ -178,6 +187,14 @@ data instance IntHashFunFam a b = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) +data family TyFamily81 x y+data instance TyFamily81 a b+ = TyFamily81a (forall c. c -> (forall d. a -> d) -> a)+ | TyFamily81b (Int -> forall c. c -> b)++data family TyFamily82 x y+data instance TyFamily82 a b = TyFamily82 (F a b)+ ------------------------------------------------------------------------------- -- Plain data types@@ -246,6 +263,12 @@ $(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) $(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBifunctor ''TyCon81)++$(deriveBifunctor ''TyCon82)+$(deriveBifoldable ''TyCon82)+$(deriveBitraversable ''TyCon82)+ #if MIN_VERSION_template_haskell(2,7,0) -- Data families @@ -303,6 +326,12 @@ $(deriveBitraversable 'IntHashFam) $(deriveBifunctor 'IntHashFunFam)++$(deriveBifunctor 'TyFamily81a)++$(deriveBifunctor 'TyFamily82)+$(deriveBifoldable 'TyFamily82)+$(deriveBitraversable 'TyFamily82) #endif -------------------------------------------------------------------------------