Hello community,
here is the log from the commit of package ghc-bifunctors for openSUSE:Factory
checked in at 2020-10-23 15:13:37
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-bifunctors (Old)
and /work/SRC/openSUSE:Factory/.ghc-bifunctors.new.3463 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-bifunctors"
Fri Oct 23 15:13:37 2020 rev:21 rq:842740 version:5.5.8
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-bifunctors/ghc-bifunctors.changes
2020-09-07 21:28:42.409197449 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-bifunctors.new.3463/ghc-bifunctors.changes
2020-10-23 15:13:38.982114040 +0200
@@ -1,0 +2,12 @@
+Tue Oct 6 08:56:02 UTC 2020 - psim...@suse.com
+
+- Update bifunctors to version 5.5.8.
+ 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.
+
+-------------------------------------------------------------------
Old:
----
bifunctors-5.5.7.tar.gz
bifunctors.cabal
New:
----
bifunctors-5.5.8.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-bifunctors.spec ++++++
--- /var/tmp/diff_new_pack.U2D2DU/_old 2020-10-23 15:13:39.974114518 +0200
+++ /var/tmp/diff_new_pack.U2D2DU/_new 2020-10-23 15:13:39.978114520 +0200
@@ -19,13 +19,12 @@
%global pkg_name bifunctors
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 5.5.7
+Version: 5.5.8
Release: 0
Summary: Collection Haskell 98 bifunctors, bifoldables and
bitraversables
License: BSD-2-Clause
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-base-orphans-devel
BuildRequires: ghc-comonad-devel
@@ -56,7 +55,6 @@
%prep
%autosetup -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ bifunctors-5.5.7.tar.gz -> bifunctors-5.5.8.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/.travis.yml
new/bifunctors-5.5.8/.travis.yml
--- old/bifunctors-5.5.7/.travis.yml 2001-09-09 03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/.travis.yml 2001-09-09 03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/CHANGELOG.markdown
new/bifunctors-5.5.8/CHANGELOG.markdown
--- old/bifunctors-5.5.7/CHANGELOG.markdown 2001-09-09 03:46:40.000000000
+0200
+++ new/bifunctors-5.5.8/CHANGELOG.markdown 2001-09-09 03:46:40.000000000
+0200
@@ -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`.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/bifunctors.cabal
new/bifunctors-5.5.8/bifunctors.cabal
--- old/bifunctors-5.5.7/bifunctors.cabal 2001-09-09 03:46:40.000000000
+0200
+++ new/bifunctors-5.5.8/bifunctors.cabal 2001-09-09 03:46:40.000000000
+0200
@@ -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 <ekm...@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,
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/old-src/ghc709/Data/Bifunctor.hs
new/bifunctors-5.5.8/old-src/ghc709/Data/Bifunctor.hs
--- old/bifunctors-5.5.7/old-src/ghc709/Data/Bifunctor.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/old-src/ghc709/Data/Bifunctor.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/old-src/ghc801/Data/Bifoldable.hs
new/bifunctors-5.5.8/old-src/ghc801/Data/Bifoldable.hs
--- old/bifunctors-5.5.7/old-src/ghc801/Data/Bifoldable.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/old-src/ghc801/Data/Bifoldable.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/bifunctors-5.5.7/old-src/ghc801/Data/Bitraversable.hs
new/bifunctors-5.5.8/old-src/ghc801/Data/Bitraversable.hs
--- old/bifunctors-5.5.7/old-src/ghc801/Data/Bitraversable.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/old-src/ghc801/Data/Bitraversable.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/src/Data/Biapplicative.hs
new/bifunctors-5.5.8/src/Data/Biapplicative.hs
--- old/bifunctors-5.5.7/src/Data/Biapplicative.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/src/Data/Biapplicative.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/src/Data/Bifunctor/Biap.hs
new/bifunctors-5.5.8/src/Data/Bifunctor/Biap.hs
--- old/bifunctors-5.5.7/src/Data/Bifunctor/Biap.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/src/Data/Bifunctor/Biap.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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'.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/src/Data/Bifunctor/TH/Internal.hs
new/bifunctors-5.5.8/src/Data/Bifunctor/TH/Internal.hs
--- old/bifunctors-5.5.7/src/Data/Bifunctor/TH/Internal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/src/Data/Bifunctor/TH/Internal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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,23 +251,52 @@
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?
--
@@ -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:
--
@@ -464,11 +471,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
bifunctorTypeName = mkNameG_tc "base" "Data.Bifunctor" "Bifunctor"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/src/Data/Bifunctor/TH.hs
new/bifunctors-5.5.8/src/Data/Bifunctor/TH.hs
--- old/bifunctors-5.5.7/src/Data/Bifunctor/TH.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/bifunctors-5.5.8/src/Data/Bifunctor/TH.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
-
--- | 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)
- []
+ 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 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
+ 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
+ }
+
+ -- 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 ..
+
+-- | 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
- mappedArgs :: Q [Either Exp Exp]
- mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args
+ -- 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
+ }
--- | 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
-
- lhsArgs, rhsArgs :: [Type]
- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
-
- tyVarNames :: [Name]
- tyVarNames = Map.keys tvMap
-
- mentionsTyArgs :: Bool
- mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs
-
- 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
+ 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
+
+-- | 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)
- )
- []
- ]
-
- makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)
- makeBiFunTupleField fieldTy fieldName =
- makeBiFunForType biFun tvMap conName covariant fieldTy
- `appEitherE` varE fieldName
-
- 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
+ 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
+
+-- | 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
+ }
+
+ -- 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,120 +999,33 @@
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
+fmapArity :: Int -> Name
+fmapArity 1 = fmapValName
+fmapArity 2 = bimapValName
+fmapArity n = arityErr n
+
+foldrArity :: Int -> Name
+foldrArity 1 = foldrValName
+foldrArity 2 = bifoldrValName
+foldrArity n = arityErr n
+
+foldMapArity :: Int -> Name
+foldMapArity 1 = foldMapValName
+foldMapArity 2 = bifoldMapValName
+foldMapArity n = arityErr n
+
+traverseArity :: Int -> Name
+traverseArity 1 = traverseValName
+traverseArity 2 = bitraverseValName
+traverseArity n = arityErr n
+
+arityErr :: Int -> a
+arityErr n = error $ "Unsupported arity: " ++ show n
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
-
- argsWithTyVar, argsWithoutTyVar :: [Name]
- (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo
args
-
- 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))
-
- conExp <- conExpQ
-
- 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
-
- return . go . rights $ ess
-
biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase biFun z value =
biFunTrivial emptyCase
@@ -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]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/bifunctors-5.5.7/tests/BifunctorSpec.hs
new/bifunctors-5.5.8/tests/BifunctorSpec.hs
--- old/bifunctors-5.5.7/tests/BifunctorSpec.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/bifunctors-5.5.8/tests/BifunctorSpec.hs 2001-09-09 03:46:40.000000000
+0200
@@ -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
-------------------------------------------------------------------------------
