Hello community, here is the log from the commit of package ghc-bifunctors for openSUSE:Factory checked in at 2018-05-30 12:01:02 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-bifunctors (Old) and /work/SRC/openSUSE:Factory/.ghc-bifunctors.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-bifunctors" Wed May 30 12:01:02 2018 rev:10 rq:607753 version:5.5.2 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-bifunctors/ghc-bifunctors.changes 2017-09-20 17:10:33.587555386 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-bifunctors.new/ghc-bifunctors.changes 2018-05-30 12:23:51.369099285 +0200 @@ -1,0 +2,18 @@ +Mon May 14 17:02:11 UTC 2018 - [email protected] + +- Update bifunctors to version 5.5.2 revision 2. + * `Data.Bifunctor.TH` now derives `bimap`/`bitraverse` + implementations for empty data types that are strict in the argument. + * `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations + that error on empty data types. Instead, they simply return the folded state + (for `bifoldr`) or `mempty` (for `bifoldMap`). + * When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable` + instances for data types where the last two type variables are at phantom + roles, generated `bimap`/`bitraverse` implementations now use `coerce` for + efficiency. + * Add `Options` to `Data.Bifunctor.TH`, along with variants of existing + functions that take `Options` as an argument. For now, the only configurable + option is whether derived instances for empty data types should use the + `EmptyCase` extension (this is disabled by default). + +------------------------------------------------------------------- Old: ---- bifunctors-5.4.2.tar.gz New: ---- bifunctors-5.5.2.tar.gz bifunctors.cabal ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-bifunctors.spec ++++++ --- /var/tmp/diff_new_pack.u8IQAV/_old 2018-05-30 12:23:51.909082574 +0200 +++ /var/tmp/diff_new_pack.u8IQAV/_new 2018-05-30 12:23:51.913082450 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-bifunctors # -# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,13 +19,14 @@ %global pkg_name bifunctors %bcond_with tests Name: ghc-%{pkg_name} -Version: 5.4.2 +Version: 5.5.2 Release: 0 Summary: Collection Haskell 98 bifunctors, bifoldables and bitraversables License: BSD-2-Clause Group: Development/Libraries/Haskell 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/2.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel BuildRequires: ghc-base-orphans-devel BuildRequires: ghc-comonad-devel @@ -34,6 +35,7 @@ BuildRequires: ghc-semigroups-devel BuildRequires: ghc-tagged-devel BuildRequires: ghc-template-haskell-devel +BuildRequires: ghc-th-abstraction-devel BuildRequires: ghc-transformers-compat-devel BuildRequires: ghc-transformers-devel %if %{with tests} @@ -57,6 +59,7 @@ %prep %setup -q -n %{pkg_name}-%{version} +cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build @@ -74,7 +77,7 @@ %ghc_pkg_recache %files -f %{name}.files -%doc LICENSE +%license LICENSE %files devel -f %{name}-devel.files %doc CHANGELOG.markdown README.markdown ++++++ bifunctors-5.4.2.tar.gz -> bifunctors-5.5.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/.travis.yml new/bifunctors-5.5.2/.travis.yml --- old/bifunctors-5.4.2/.travis.yml 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/.travis.yml 2018-02-06 19:24:49.000000000 +0100 @@ -1,114 +1,147 @@ -# This file has been generated -- see https://github.com/hvr/multi-ghc-travis +# This Travis job script has been generated by a script via +# +# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project' +# +# For more information, see https://github.com/hvr/multi-ghc-travis +# language: c sudo: false +git: + submodules: false # whether to recursively clone submodules + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313bifunctors\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + cache: directories: - - $HOME/.cabsnap - $HOME/.cabal/packages + - $HOME/.cabal/store before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + + - rm -rfv $HOME/.cabal/packages/head.hackage matrix: include: - - env: CABALVER=1.18 GHCVER=7.0.4 - compiler: ": #GHC 7.0.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.0.4], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.2.2 - compiler: ": #GHC 7.2.2" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.4.2 - compiler: ": #GHC 7.4.2" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.6.3 - compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.8.4 - compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.10.3 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=8.0.2 - compiler: ": #GHC 8.0.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} - - env: CABALVER=2.0 GHCVER=8.2.1 - compiler: ": #GHC 8.2.1" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}} - - env: CABALVER=head GHCVER=head - compiler: ": #GHC head" - addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} + - compiler: "ghc-7.0.4" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}} + - compiler: "ghc-7.2.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}} + - compiler: "ghc-7.4.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}} + - compiler: "ghc-7.6.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}} + - compiler: "ghc-7.8.4" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}} + - compiler: "ghc-7.10.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}} + - compiler: "ghc-8.0.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.2.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.4.1" + env: GHCHEAD=true + addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}} + - compiler: "ghc-head" + env: GHCHEAD=true + addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}} allow_failures: - - env: CABALVER=1.18 GHCVER=7.0.4 - - env: CABALVER=1.18 GHCVER=7.2.2 - - env: CABALVER=head GHCVER=head + - compiler: "ghc-7.0.4" + - compiler: "ghc-7.2.2" + - compiler: "ghc-8.4.1" + - compiler: "ghc-head" before_install: - - unset CC - - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - ROOTDIR=$(pwd) + - mkdir -p $HOME/.local/bin + - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" + - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - echo $HCNUMVER install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; - then - zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > - $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; - fi - - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt - - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt - -# check whether current requested install-plan matches cached package-db snapshot - - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; - then - echo "cabal build-cache HIT"; - rm -rfv .ghc; - cp -a $HOME/.cabsnap/ghc $HOME/.ghc; - cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; - else - echo "cabal build-cache MISS"; - rm -rf $HOME/.cabsnap; - mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install -j --only-dependencies --enable-tests; - fi - -# snapshot package-db on cache miss - - if [ ! -d $HOME/.cabsnap ]; - then - echo "snapshotting package-db to build-cache"; - mkdir $HOME/.cabsnap; - cp -a $HOME/.ghc $HOME/.cabsnap/ghc; - cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; - fi + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - HADDOCK=${HADDOCK-true} + - INSTALLED=${INSTALLED-true} + - GHCHEAD=${GHCHEAD-false} + - travis_retry cabal update -v + - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" + - rm -fv cabal.project cabal.project.local + # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage + - | + if $GHCHEAD; then + sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config + + echo 'repository head.hackage' >> ${HOME}/.cabal/config + echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config + echo ' secure: True' >> ${HOME}/.cabal/config + echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config + echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config + echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config + echo ' key-threshold: 3' >> ${HOME}/.cabal.config + + cabal new-update head.hackage -v + fi + - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + - "printf 'packages: \".\"\\n' > cabal.project" + - cat cabal.project + - if [ -f "./configure.ac" ]; then + (cd "." && autoreconf -i); + fi + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all + - rm -rf "."/.ghc.environment.* "."/dist + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - - cabal configure -v2 --enable-tests # -v2 provides useful information for debugging - - cabal build # this builds all libraries and executables (including tests/benchmarks) - - cabal test --show-details=always - - cabal haddock - - cabal sdist # tests that a source-distribution can be generated - - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313bifunctors\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" + # test that source-distributions can be generated + - (cd "." && cabal sdist) + - mv "."/dist/bifunctors-*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; + - "printf 'packages: bifunctors-*/*.cabal\\n' > cabal.project" + - cat cabal.project + + + # build & run tests, build benchmarks + - cabal new-build -w ${HC} ${TEST} ${BENCH} all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi + + # cabal check + - (cd bifunctors-* && cabal check) + + # haddock + - rm -rf ./dist-newstyle + - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi +# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"] # EOF diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/CHANGELOG.markdown new/bifunctors-5.5.2/CHANGELOG.markdown --- old/bifunctors-5.4.2/CHANGELOG.markdown 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/CHANGELOG.markdown 2018-02-06 19:24:49.000000000 +0100 @@ -1,3 +1,27 @@ +5.5.2 [2018.02.06] +------------------ +* Don't enable `Safe` on GHC 7.2. + +5.5.1 [2018.02.04] +------------------ +* Test suite fixes for GHC 8.4. + +5.5 [2017.12.07] +---------------- +* `Data.Bifunctor.TH` now derives `bimap`/`bitraverse` + implementations for empty data types that are strict in the argument. +* `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations + that error on empty data types. Instead, they simply return the folded state + (for `bifoldr`) or `mempty` (for `bifoldMap`). +* When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable` + instances for data types where the last two type variables are at phantom + roles, generated `bimap`/`bitraverse` implementations now use `coerce` for + efficiency. +* Add `Options` to `Data.Bifunctor.TH`, along with variants of existing + functions that take `Options` as an argument. For now, the only configurable + option is whether derived instances for empty data types should use the + `EmptyCase` extension (this is disabled by default). + 5.4.2 ----- * Make `deriveBitraversable` use `liftA2` in derived implementations of `bitraverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/bifunctors.cabal new/bifunctors-5.5.2/bifunctors.cabal --- old/bifunctors-5.4.2/bifunctors.cabal 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/bifunctors.cabal 2018-02-06 19:24:49.000000000 +0100 @@ -1,6 +1,6 @@ name: bifunctors category: Data, Functors -version: 5.4.2 +version: 5.5.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -11,9 +11,9 @@ bug-reports: http://github.com/ekmett/bifunctors/issues copyright: Copyright (C) 2008-2016 Edward A. Kmett synopsis: Bifunctors -description: Bifunctors +description: Bifunctors. build-type: Simple -tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 +tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown source-repository head @@ -44,6 +44,7 @@ comonad >= 4 && < 6, containers >= 0.1 && < 0.6, template-haskell >= 2.4 && < 2.13, + th-abstraction >= 0.2.2 && < 0.3, transformers >= 0.2 && < 0.6, transformers-compat >= 0.5 && < 0.6 @@ -94,6 +95,7 @@ main-is: Spec.hs other-modules: BifunctorSpec ghc-options: -Wall + build-tool-depends: hspec-discover:hspec-discover >= 1.8 build-depends: base >= 4 && < 5, bifunctors, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/src/Data/Biapplicative.hs new/bifunctors-5.5.2/src/Data/Biapplicative.hs --- old/bifunctors-5.4.2/src/Data/Biapplicative.hs 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/src/Data/Biapplicative.hs 2018-02-06 19:24:49.000000000 +0100 @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_semigroups diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/src/Data/Bifunctor/Functor.hs new/bifunctors-5.5.2/src/Data/Bifunctor/Functor.hs --- old/bifunctors-5.4.2/src/Data/Bifunctor/Functor.hs 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/src/Data/Bifunctor/Functor.hs 2018-02-06 19:24:49.000000000 +0100 @@ -2,8 +2,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 706 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/src/Data/Bifunctor/TH/Internal.hs new/bifunctors-5.5.2/src/Data/Bifunctor/TH/Internal.hs --- old/bifunctors-5.4.2/src/Data/Bifunctor/TH/Internal.hs 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/src/Data/Bifunctor/TH/Internal.hs 2018-02-06 19:24:49.000000000 +0100 @@ -15,17 +15,16 @@ -} module Data.Bifunctor.TH.Internal where -import Control.Monad (liftM) - import Data.Bifunctor (bimap) import Data.Foldable (foldr') import Data.List -import qualified Data.Map as Map (fromList, findWithDefault, singleton) +import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Set (Set) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -43,73 +42,15 @@ -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the --- @genifunctors@ package (licensed under BSD3). -expandSyn :: Type -> Q Type -expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t -expandSyn t@AppT{} = expandSynApp t [] -expandSyn t@ConT{} = expandSynApp t [] -expandSyn (SigT t k) = do t' <- expandSyn t - k' <- expandSynKind k - return (SigT t' k') -expandSyn t = return t - -expandSynKind :: Kind -> Q Kind -#if MIN_VERSION_template_haskell(2,8,0) -expandSynKind = expandSyn -#else -expandSynKind = return -- There are no kind synonyms to deal with -#endif - -expandSynApp :: Type -> [Type] -> Q Type -expandSynApp (AppT t1 t2) ts = do - t2' <- expandSyn t2 - expandSynApp t1 (t2':ts) -expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts -expandSynApp t@(ConT n) ts = do - info <- reify n - case info of - TyConI (TySynD _ tvs rhs) -> - let (ts', ts'') = splitAt (length tvs) ts - subs = mkSubst tvs ts' - rhs' = substType subs rhs - in expandSynApp rhs' ts'' - _ -> return $ foldl' AppT t ts -expandSynApp t ts = do - t' <- expandSyn t - return $ foldl' AppT t' ts - -type TypeSubst = Map Name Type -type KindSubst = Map Name Kind - -mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst -mkSubst vs ts = - let vs' = map un vs - un (PlainTV v) = v - un (KindedTV v _) = v - in Map.fromList $ zip vs' ts - -substType :: TypeSubst -> Type -> Type -substType subs (ForallT v c t) = ForallT v c $ substType subs t -substType subs t@(VarT n) = Map.findWithDefault t n subs -substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2) -substType subs (SigT t k) = SigT (substType subs t) -#if MIN_VERSION_template_haskell(2,8,0) - (substType subs k) -#else - k -#endif -substType _ t = t - -substKind :: KindSubst -> Type -> Type +applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0) -substKind = substType +applySubstitutionKind = applySubstitution #else -substKind _ = id -- There are no kind variables! +applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = substKind (Map.singleton n k) +substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns @@ -254,27 +195,6 @@ #endif isStarOrVar _ = False --- | Gets all of the type/kind variable names mentioned somewhere in a Type. -tyVarNamesOfType :: Type -> [Name] -tyVarNamesOfType = go - where - go :: Type -> [Name] - go (AppT t1 t2) = go t1 ++ go t2 - go (SigT t _k) = go t -#if MIN_VERSION_template_haskell(2,8,0) - ++ go _k -#endif - go (VarT n) = [n] - go _ = [] - --- | Gets all of the type/kind variable names mentioned somewhere in a Kind. -tyVarNamesOfKind :: Kind -> [Name] -#if MIN_VERSION_template_haskell(2,8,0) -tyVarNamesOfKind = tyVarNamesOfType -#else -tyVarNamesOfKind _ = [] -- There are no kind variables -#endif - -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. @@ -282,7 +202,7 @@ hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (concatMap tyVarNamesOfKind uk) + then Just (freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. @@ -290,15 +210,6 @@ tyKind (SigT _ k) = k tyKind _ = starK --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. -stealKindForType :: TyVarBndr -> Type -> Type -stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) -stealKindForType _ t = t - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - -- | A mapping of type variable Names to their map function Names. For example, in a -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where -- a and b are the last two type variables of the datatype, and f and g are the two @@ -308,31 +219,16 @@ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c --- | Extracts the name of a constructor. -constructorName :: Con -> Name -constructorName (NormalC name _ ) = name -constructorName (RecC name _ ) = name -constructorName (InfixC _ name _ ) = name -constructorName (ForallC _ _ con) = constructorName con -#if MIN_VERSION_template_haskell(2,11,0) -constructorName (GadtC names _ _) = head names -constructorName (RecGadtC names _ _) = head names -#endif +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = case unsnoc xs of + Nothing -> Just ([], x) + Just (a,b) -> Just (x:a, b) -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] --- | Extracts the kind from a TyVarBndr. -tvbKind :: TyVarBndr -> Kind -tvbKind (PlainTV _) = starK -tvbKind (KindedTV _ k) = k - --- | Convert a TyVarBndr to a Type. -tvbToType :: TyVarBndr -> Type -tvbToType (PlainTV n) = VarT n -tvbToType (KindedTV n k) = SigT (VarT n) k - -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred #if MIN_VERSION_template_haskell(2,10,0) @@ -520,15 +416,12 @@ bifoldMapConstValName :: Name bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst" +coerceValName :: Name +coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" + bitraverseConstValName :: Name bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" - -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" - wrapMonadDataName :: Name wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" @@ -541,9 +434,6 @@ traversableTypeName :: Name traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" - composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." @@ -565,8 +455,8 @@ foldMapValName :: Name foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" +seqValName :: Name +seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" @@ -654,3 +544,29 @@ bitraverseValName :: Name bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse" #endif + +#if MIN_VERSION_base(4,11,0) +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" +#else +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/src/Data/Bifunctor/TH.hs new/bifunctors-5.5.2/src/Data/Bifunctor/TH.hs --- old/bifunctors-5.4.2/src/Data/Bifunctor/TH.hs 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/src/Data/Bifunctor/TH.hs 2018-02-06 19:24:49.000000000 +0100 @@ -31,32 +31,45 @@ -- $make -- * 'Bifunctor' deriveBifunctor + , deriveBifunctorOptions , makeBimap + , makeBimapOptions -- * 'Bifoldable' , deriveBifoldable + , deriveBifoldableOptions , makeBifold + , makeBifoldOptions , makeBifoldMap + , makeBifoldMapOptions , makeBifoldr + , makeBifoldrOptions , makeBifoldl + , makeBifoldlOptions -- * 'Bitraversable' , deriveBitraversable + , deriveBitraversableOptions , makeBitraverse + , makeBitraverseOptions , makeBisequenceA + , makeBisequenceAOptions , makeBimapM + , makeBimapMOptions , makeBisequence + , makeBisequenceOptions + -- * 'Options' + , Options(..) + , defaultOptions ) where import Control.Monad (guard, unless, when, zipWithM) import Data.Bifunctor.TH.Internal import Data.Either (rights) -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) -import Data.Foldable (foldr') -#endif import Data.List import qualified Data.Map as Map (fromList, keys, lookup, size) import Data.Maybe +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax @@ -65,6 +78,22 @@ -- User-facing API ------------------------------------------------------------------------------- +-- | Options that further configure how the functions in "Data.Bifunctor.TH" +-- should behave. +newtype Options = Options + { emptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + } deriving (Eq, Ord, Read, Show) + +-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to +-- prevent users from having to enable that extension at use sites.) +defaultOptions :: Options +defaultOptions = Options { emptyCaseBehavior = False } + {- $derive 'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically @@ -166,40 +195,68 @@ -- | Generates a 'Bifunctor' instance declaration for the given data type or data -- family instance. deriveBifunctor :: Name -> Q [Dec] -deriveBifunctor = deriveBiClass Bifunctor +deriveBifunctor = deriveBifunctorOptions defaultOptions + +-- | Like 'deriveBifunctor', but takes an 'Options' argument. +deriveBifunctorOptions :: Options -> Name -> Q [Dec] +deriveBifunctorOptions = deriveBiClass Bifunctor -- | Generates a lambda expression which behaves like 'bimap' (without requiring a -- 'Bifunctor' instance). makeBimap :: Name -> Q Exp -makeBimap = makeBiFun Bimap +makeBimap = makeBimapOptions defaultOptions + +-- | Like 'makeBimap', but takes an 'Options' argument. +makeBimapOptions :: Options -> Name -> Q Exp +makeBimapOptions = makeBiFun Bimap -- | Generates a 'Bifoldable' instance declaration for the given data type or data -- family instance. deriveBifoldable :: Name -> Q [Dec] -deriveBifoldable = deriveBiClass Bifoldable +deriveBifoldable = deriveBifoldableOptions defaultOptions + +-- | Like 'deriveBifoldable', but takes an 'Options' argument. +deriveBifoldableOptions :: Options -> Name -> Q [Dec] +deriveBifoldableOptions = deriveBiClass Bifoldable --- | Generates a lambda expression which behaves like 'bifold' (without requiring a +--- | Generates a lambda expression which behaves like 'bifold' (without requiring a -- 'Bifoldable' instance). makeBifold :: Name -> Q Exp -makeBifold name = appsE [ makeBifoldMap name - , varE idValName - , varE idValName - ] +makeBifold = makeBifoldOptions defaultOptions --- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a --- 'Bifoldable' instance). +-- | Like 'makeBifold', but takes an 'Options' argument. +makeBifoldOptions :: Options -> Name -> Q Exp +makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name + , varE idValName + , varE idValName + ] + +-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring +-- a 'Bifoldable' instance). makeBifoldMap :: Name -> Q Exp -makeBifoldMap = makeBiFun BifoldMap +makeBifoldMap = makeBifoldMapOptions defaultOptions + +-- | Like 'makeBifoldMap', but takes an 'Options' argument. +makeBifoldMapOptions :: Options -> Name -> Q Exp +makeBifoldMapOptions = makeBiFun BifoldMap -- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a -- 'Bifoldable' instance). makeBifoldr :: Name -> Q Exp -makeBifoldr = makeBiFun Bifoldr +makeBifoldr = makeBifoldrOptions defaultOptions + +-- | Like 'makeBifoldr', but takes an 'Options' argument. +makeBifoldrOptions :: Options -> Name -> Q Exp +makeBifoldrOptions = makeBiFun Bifoldr -- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a -- 'Bifoldable' instance). makeBifoldl :: Name -> Q Exp -makeBifoldl name = do +makeBifoldl = makeBifoldlOptions defaultOptions + +-- | Like 'makeBifoldl', but takes an 'Options' argument. +makeBifoldlOptions :: Options -> Name -> Q Exp +makeBifoldlOptions opts name = do f <- newName "f" g <- newName "g" z <- newName "z" @@ -207,7 +264,10 @@ lamE [varP f, varP g, varP z, varP t] $ appsE [ varE appEndoValName , appsE [ varE getDualValName - , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t] + , appsE [ makeBifoldMapOptions opts name + , foldFun f + , foldFun g + , varE t] ] , varE z ] @@ -223,112 +283,195 @@ -- | Generates a 'Bitraversable' instance declaration for the given data type or data -- family instance. deriveBitraversable :: Name -> Q [Dec] -deriveBitraversable = deriveBiClass Bitraversable +deriveBitraversable = deriveBitraversableOptions defaultOptions --- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a --- 'Bitraversable' instance). +-- | Like 'deriveBitraversable', but takes an 'Options' argument. +deriveBitraversableOptions :: Options -> Name -> Q [Dec] +deriveBitraversableOptions = deriveBiClass Bitraversable + +-- | Generates a lambda expression which behaves like 'bitraverse' (without +-- requiring a 'Bitraversable' instance). makeBitraverse :: Name -> Q Exp -makeBitraverse = makeBiFun Bitraverse +makeBitraverse = makeBitraverseOptions defaultOptions + +-- | Like 'makeBitraverse', but takes an 'Options' argument. +makeBitraverseOptions :: Options -> Name -> Q Exp +makeBitraverseOptions = makeBiFun Bitraverse --- | Generates a lambda expression which behaves like 'bisequenceA' (without requiring a --- 'Bitraversable' instance). +-- | Generates a lambda expression which behaves like 'bisequenceA' (without +-- requiring a 'Bitraversable' instance). makeBisequenceA :: Name -> Q Exp -makeBisequenceA name = appsE [ makeBitraverse name - , varE idValName - , varE idValName - ] +makeBisequenceA = makeBisequenceAOptions defaultOptions --- | Generates a lambda expression which behaves like 'bimapM' (without requiring a --- 'Bitraversable' instance). +-- | Like 'makeBitraverseA', but takes an 'Options' argument. +makeBisequenceAOptions :: Options -> Name -> Q Exp +makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name + , varE idValName + , varE idValName + ] + +-- | Generates a lambda expression which behaves like 'bimapM' (without +-- requiring a 'Bitraversable' instance). makeBimapM :: Name -> Q Exp -makeBimapM name = do +makeBimapM = makeBimapMOptions defaultOptions + +-- | Like 'makeBimapM', but takes an 'Options' argument. +makeBimapMOptions :: Options -> Name -> Q Exp +makeBimapMOptions opts name = do f <- newName "f" g <- newName "g" lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ - appsE [makeBitraverse name, wrapMonadExp f, wrapMonadExp g] + appsE [ makeBitraverseOptions opts name + , wrapMonadExp f + , wrapMonadExp g + ] where wrapMonadExp :: Name -> Q Exp wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) --- | Generates a lambda expression which behaves like 'bisequence' (without requiring a --- 'Bitraversable' instance). +-- | Generates a lambda expression which behaves like 'bisequence' (without +-- requiring a 'Bitraversable' instance). makeBisequence :: Name -> Q Exp -makeBisequence name = appsE [ makeBimapM name - , varE idValName - , varE idValName - ] +makeBisequence = makeBisequenceOptions defaultOptions + +-- | Like 'makeBisequence', but takes an 'Options' argument. +makeBisequenceOptions :: Options -> Name -> Q Exp +makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name + , varE idValName + , varE idValName + ] ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a class instance declaration (depending on the BiClass argument's value). -deriveBiClass :: BiClass -> Name -> Q [Dec] -deriveBiClass biClass name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance biClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (biFunDecs biClass cons) +deriveBiClass :: BiClass -> Options -> Name -> Q [Dec] +deriveBiClass biClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance biClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (biFunDecs biClass opts parentName vars cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and -- bitraverse for Bitraversable). -- -- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436. -biFunDecs :: BiClass -> [Con] -> [Q Dec] -biFunDecs biClass cons = map makeFunD $ biClassToFuns biClass where - makeFunD :: BiFun -> Q Dec - makeFunD biFun = - funD (biFunName biFun) - [ clause [] - (normalB $ makeBiFunForCons biFun cons) - [] - ] +biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] +biFunDecs biClass opts parentName vars cons = + map makeFunD $ biClassToFuns biClass + where + makeFunD :: BiFun -> Q Dec + makeFunD biFun = + funD (biFunName biFun) + [ clause [] + (normalB $ makeBiFunForCons biFun opts parentName vars cons) + [] + ] -- | Generates a lambda expression which behaves like the BiFun argument. -makeBiFun :: BiFun -> Name -> Q Exp -makeBiFun biFun name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance (biFunToClass biFun) name' ctxt tvbs mbTys - `seq` makeBiFunForCons biFun cons +makeBiFun :: BiFun -> Options -> Name -> Q Exp +makeBiFun biFun opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance (biFunToClass biFun) parentName ctxt vars variant + >> makeBiFunForCons biFun opts parentName vars cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. -makeBiFunForCons :: BiFun -> [Con] -> Q Exp -makeBiFunForCons biFun cons = do +makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp +makeBiFunForCons biFun opts _parentName vars 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 + z = head others -- If we're deriving bifoldr, this will be well defined + -- and useful. Otherwise, it'll be ignored. + value = last others + lastTyVars = map varTToName $ drop (length vars - 2) vars + tvMap = Map.fromList $ zip lastTyVars [map1, map2] lamE (map varP argNames) . appsE $ [ varE $ biFunConstName biFun - , if null cons - then appE (varE errorValName) - (stringE $ "Void " ++ nameBase (biFunName biFun)) - else caseE (varE value) - (map (makeBiFunForCon biFun z map1 map2) cons) + , makeFun z value tvMap ] ++ map varE argNames + where + makeFun :: Name -> Name -> TyVarMap -> Q Exp + makeFun z value tvMap = do +#if MIN_VERSION_template_haskell(2,9,0) + roles <- reifyRoles _parentName +#endif + case () of + _ + +#if MIN_VERSION_template_haskell(2,9,0) + | Just (rs, PhantomR) <- unsnoc roles + , Just (_, PhantomR) <- unsnoc rs + -> biFunPhantom z value +#endif + + | null cons && emptyCaseBehavior opts && ghc7'8OrLater + -> biFunEmptyCase biFun z value + + | null cons + -> biFunNoCons biFun z value + + | otherwise + -> caseE (varE value) + (map (makeBiFunForCon biFun z tvMap) cons) + + ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 + ghc7'8OrLater = True +#else + ghc7'8OrLater = False +#endif + +#if MIN_VERSION_template_haskell(2,9,0) + biFunPhantom :: Name -> Name -> Q Exp + biFunPhantom z value = + biFunTrivial coerce + (varE pureValName `appE` coerce) + biFun z + where + coerce :: Q Exp + coerce = varE coerceValName `appE` varE value +#endif -- | Generates a lambda expression for a single constructor. -makeBiFunForCon :: BiFun -> Name -> Name -> Name -> Con -> Q Match -makeBiFunForCon biFun z map1 map2 con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys biFun conName map1 map2 - argNames <- newNameList "_arg" $ length ts - makeBiFunForArgs biFun z tvMap conName ts argNames +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 @@ -455,196 +598,27 @@ -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - con _ -> f name ctxt tvbs [con] Nothing - _ -> error $ ns ++ "Unsupported type: " ++ show dec -#if MIN_VERSION_template_haskell(2,7,0) -# if MIN_VERSION_template_haskell(2,11,0) - DataConI _ _ parentName -> do -# else - DataConI _ _ parentName _ -> do -# endif - parentInfo <- reify parentName - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> error $ ns ++ - "Could not find data or newtype instance constructor." - _ -> error $ ns ++ "Data constructor " ++ show name ++ - " is not from a data family instance constructor." -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI DataFamilyD{} _ -> -# else - FamilyI (FamilyD DataFam _ _ _) _ -> -# endif - error $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> error $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Bifunctor.TH.withType: " - --- | Deduces the instance context and head for an instance. +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] buildTypeInstance :: BiClass -- ^ Bifunctor, Bifoldable, or Bitraversable -> Name -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not -> Q (Cxt, Type) --- Plain data type/newtype case -buildTypeInstance biClass tyConName dataCxt tvbs Nothing = - let varTys :: [Type] - varTys = map tvbToType tvbs - in buildTypeInstanceFromTys biClass tyConName dataCxt varTys False --- Data family instance case --- --- The CPP is present to work around a couple of annoying old GHC bugs. --- See Note [Polykinded data families in Template Haskell] -buildTypeInstance biClass parentName dataCxt tvbs (Just instTysAndKinds) = do -#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) - let instTys :: [Type] - instTys = zipWith stealKindForType tvbs instTysAndKinds -#else - let kindVarNames :: [Name] - kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs - - numKindVars :: Int - numKindVars = length kindVarNames - - givenKinds, givenKinds' :: [Kind] - givenTys :: [Type] - (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds - givenKinds' = map sanitizeStars givenKinds - - -- A GHC 7.6-specific bug requires us to replace all occurrences of - -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. - -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. - sanitizeStars :: Kind -> Kind - sanitizeStars = go - where - go :: Kind -> Kind - go (AppT t1 t2) = AppT (go t1) (go t2) - go (SigT t k) = SigT (go t) (go k) - go (ConT n) | n == starKindName = StarT - go t = t - - -- If we run this code with GHC 7.8, we might have to generate extra type - -- variables to compensate for any type variables that Template Haskell - -- eta-reduced away. - -- See Note [Polykinded data families in Template Haskell] - xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) - - let xTys :: [Type] - xTys = map VarT xTypeNames - -- ^ Because these type variables were eta-reduced away, we can only - -- determine their kind by using stealKindForType. Therefore, we mark - -- them as VarT to ensure they will be given an explicit kind annotation - -- (and so the kind inference machinery has the right information). - - substNamesWithKinds :: [(Name, Kind)] -> Type -> Type - substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks - - -- The types from the data family instance might not have explicit kind - -- annotations, which the kind machinery needs to work correctly. To - -- compensate, we use stealKindForType to explicitly annotate any - -- types without kind annotations. - instTys :: [Type] - instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) - -- Note that due to a GHC 7.8-specific bug - -- (see Note [Polykinded data families in Template Haskell]), - -- there may be more kind variable names than there are kinds - -- to substitute. But this is OK! If a kind is eta-reduced, it - -- means that is was not instantiated to something more specific, - -- so we need not substitute it. Using stealKindForType will - -- grab the correct kind. - $ zipWith stealKindForType tvbs (givenTys ++ xTys) -#endif - buildTypeInstanceFromTys biClass parentName dataCxt instTys True - --- For the given Types, generate an instance context and head. Coming up with --- the instance type isn't as simple as dropping the last types, as you need to --- be wary of kinds being instantiated with *. --- See Note [Type inference in derived instances] -buildTypeInstanceFromTys :: BiClass - -- ^ Bifunctor, Bifoldable, or Bitraversable - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [Type] - -- ^ The types to instantiate the instance with - -> Bool - -- ^ True if it's a data family, False otherwise - -> Q (Cxt, Type) -buildTypeInstanceFromTys biClass tyConName dataCxt varTysOrig isDataFamily = do +buildTypeInstance biClass tyConName dataCxt varTysOrig variant = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.) - varTysExp <- mapM expandSyn varTysOrig + varTysExp <- mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - 2 @@ -674,7 +648,7 @@ -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] - droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. @@ -715,6 +689,13 @@ map (substNamesWithKindStar (union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig + isDataFamily :: Bool + isDataFamily = case variant of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. @@ -759,55 +740,6 @@ tName = varTToName t {- -Note [Polykinded data families in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In order to come up with the correct instance context and head for an instance, e.g., - - instance C a => C (Data a) where ... - -We need to know the exact types and kinds used to instantiate the instance. For -plain old datatypes, this is simple: every type must be a type variable, and -Template Haskell reliably tells us the type variables and their kinds. - -Doing the same for data families proves to be much harder for three reasons: - -1. On any version of Template Haskell, it may not tell you what an instantiated - type's kind is. For instance, in the following data family instance: - - data family Fam (f :: * -> *) (a :: *) - data instance Fam f a - - Then if we use TH's reify function, it would tell us the TyVarBndrs of the - data family declaration are: - - [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] - - and the instantiated types of the data family instance are: - - [VarT f1,VarT a1] - - We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we - have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the - kind is in case an instantiated type isn't a SigT, so we use the stealKindForType - function to ensure all of the instantiated types are SigTs before passing them - to buildTypeInstanceFromTys. -2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of - the specified kinds of a data family instance efore any of the instantiated - types. Fortunately, this is easy to deal with: you simply count the number of - distinct kind variables in the data family declaration, take that many elements - from the front of the Types list of the data family instance, substitute the - kind variables with their respective instantiated kinds (which you took earlier), - and proceed as normal. -3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template - Haskell might not even list all of the Types of a data family instance, since - they are eta-reduced away! And yes, kinds can be eta-reduced too. - - The simplest workaround is to count how many instantiated types are missing from - the list and generate extra type variables to use in their place. Luckily, we - needn't worry much if its kind was eta-reduced away, since using stealKindForType - will get it back. - Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -883,49 +815,6 @@ kind substitution as in the other case. -} --- Determines the types of a constructor's arguments as well as the last type --- parameters (along with their map functions), expanding through any type synonyms. --- The type parameters are determined on a constructor-by-constructor basis since --- they may be refined to be particular types in a GADT. -reifyConTys :: BiFun - -> Name - -> Name - -> Name - -> Q ([Type], TyVarMap) -reifyConTys biFun conName map1 map2 = do - info <- reify conName - (ctxt, uncTy) <- case info of - DataConI _ ty _ -#if !(MIN_VERSION_template_haskell(2,11,0)) - _ -#endif - -> fmap uncurryTy (expandSyn ty) - _ -> error "Must be a data constructor" - let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy - unapResTy = unapplyTy resTy - -- If one of the last type variables is refined to a particular type - -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply map functions to arguments of - -- a type that it (1) one of the last type variables, and (2) - -- of a truly polymorphic type. - mbTvNames = map varTToName_maybe $ - drop (length unapResTy - 2) unapResTy - -- We use Map.fromList to ensure that if there are any duplicate type - -- variables (as can happen in a GADT), the rightmost type variable gets - -- associated with the map function. - -- - -- See Note [Matching functions with GADT type variables] - tvMap = Map.fromList - . catMaybes -- Drop refined types - $ zipWith (\mbTvName sp -> - fmap (\tvName -> (tvName, sp)) mbTvName) - mbTvNames [map1, map2] - if (any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < 2) - && not (allowExQuant (biFunToClass biFun)) - then existentialContextError conName - else return (argTys, tvMap) - {- Note [Matching functions with GADT type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1025,17 +914,6 @@ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. -dataConIError :: a -dataConIError = error - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive for a data family instance," - . showString "\n\tuse GHC >= 7.4 instead.)" - $ "" -#endif - ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- @@ -1196,6 +1074,35 @@ return . go . rights $ ess +biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp +biFunEmptyCase biFun z value = + biFunTrivial emptyCase + (varE pureValName `appE` emptyCase) + biFun z + where + emptyCase :: Q Exp + emptyCase = caseE (varE value) [] + +biFunNoCons :: BiFun -> Name -> Name -> Q Exp +biFunNoCons biFun z value = + biFunTrivial seqAndError + (varE pureValName `appE` seqAndError) + biFun z + where + seqAndError :: Q Exp + seqAndError = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (biFunName biFun)) + +biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp +biFunTrivial bimapE bitraverseE biFun z = go biFun + where + go :: BiFun -> Q Exp + go Bimap = bimapE + go Bifoldr = varE z + go BifoldMap = varE memptyValName + go Bitraverse = bitraverseE + {- Note [biFunTriv for Bifoldable and Bitraversable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/bifunctors-5.4.2/tests/BifunctorSpec.hs new/bifunctors-5.5.2/tests/BifunctorSpec.hs --- old/bifunctors-5.4.2/tests/BifunctorSpec.hs 2017-04-19 17:08:41.000000000 +0200 +++ new/bifunctors-5.5.2/tests/BifunctorSpec.hs 2018-02-06 19:24:49.000000000 +0100 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -8,6 +9,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE RoleAnnotations #-} +#endif + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800 @@ -105,6 +111,12 @@ data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) +data Empty1 a b +data Empty2 a b +#if __GLASGOW_HASKELL__ >= 708 +type role Empty2 nominal nominal +#endif + -- Data families data family StrangeFam x y z @@ -188,14 +200,31 @@ instance (Bifunctor (f Int), Functor g) => Bifunctor (ComplexConstraint f g) where bimap = $(makeBimap ''ComplexConstraint) + instance (Bifoldable (f Int), Foldable g) => Bifoldable (ComplexConstraint f g) where bifoldr = $(makeBifoldr ''ComplexConstraint) bifoldMap = $(makeBifoldMap ''ComplexConstraint) + +bifoldlComplexConstraint + :: (Bifoldable (f Int), Foldable g) + => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraint f g a b -> c +bifoldlComplexConstraint = $(makeBifoldl ''ComplexConstraint) + +bifoldComplexConstraint + :: (Bifoldable (f Int), Foldable g, Monoid m) + => ComplexConstraint f g m m -> m +bifoldComplexConstraint = $(makeBifold ''ComplexConstraint) + instance (Bitraversable (f Int), Traversable g) => Bitraversable (ComplexConstraint f g) where bitraverse = $(makeBitraverse ''ComplexConstraint) +bisequenceAComplexConstraint + :: (Bitraversable (f Int), Traversable g, Applicative t) + => ComplexConstraint f g (t a) (t b) -> t (ComplexConstraint f g a b) +bisequenceAComplexConstraint = $(makeBisequenceA ''ComplexConstraint) + $(deriveBifunctor ''Universal) $(deriveBifunctor ''Existential) @@ -208,6 +237,15 @@ $(deriveBifunctor ''IntHashFun) +$(deriveBifunctor ''Empty1) +$(deriveBifoldable ''Empty1) +$(deriveBitraversable ''Empty1) + +-- Use EmptyCase here +$(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) + #if MIN_VERSION_template_haskell(2,7,0) -- Data families @@ -229,14 +267,31 @@ instance (Bifunctor (f Int), Functor g) => Bifunctor (ComplexConstraintFam f g) where bimap = $(makeBimap 'ComplexConstraintFam) + instance (Bifoldable (f Int), Foldable g) => Bifoldable (ComplexConstraintFam f g) where bifoldr = $(makeBifoldr 'ComplexConstraintFam) bifoldMap = $(makeBifoldMap 'ComplexConstraintFam) + +bifoldlComplexConstraintFam + :: (Bifoldable (f Int), Foldable g) + => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraintFam f g a b -> c +bifoldlComplexConstraintFam = $(makeBifoldl 'ComplexConstraintFam) + +bifoldComplexConstraintFam + :: (Bifoldable (f Int), Foldable g, Monoid m) + => ComplexConstraintFam f g m m -> m +bifoldComplexConstraintFam = $(makeBifold 'ComplexConstraintFam) + instance (Bitraversable (f Int), Traversable g) => Bitraversable (ComplexConstraintFam f g) where bitraverse = $(makeBitraverse 'ComplexConstraintFam) +bisequenceAComplexConstraintFam + :: (Bitraversable (f Int), Traversable g, Applicative t) + => ComplexConstraintFam f g (t a) (t b) -> t (ComplexConstraintFam f g a b) +bisequenceAComplexConstraintFam = $(makeBisequenceA 'ComplexConstraintFam) + $(deriveBifunctor 'UniversalFam) $(deriveBifunctor 'ExistentialListFam) ++++++ bifunctors.cabal ++++++ name: bifunctors category: Data, Functors version: 5.5.2 x-revision: 2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <[email protected]> stability: provisional homepage: http://github.com/ekmett/bifunctors/ bug-reports: http://github.com/ekmett/bifunctors/issues copyright: Copyright (C) 2008-2016 Edward A. Kmett synopsis: Bifunctors description: Bifunctors. build-type: Simple tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown source-repository head type: git location: https://github.com/ekmett/bifunctors.git flag semigroups default: True manual: True description: You can disable the use of the `semigroups` package using `-f-semigroups`. . Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. flag tagged default: True manual: True description: You can disable the use of the `tagged` package using `-f-tagged`. . Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. library hs-source-dirs: src build-depends: base >= 4 && < 5, base-orphans >= 0.5.2 && < 1, comonad >= 4 && < 6, containers >= 0.1 && < 0.6, template-haskell >= 2.4 && < 2.14, th-abstraction >= 0.2.2 && < 0.3, transformers >= 0.2 && < 0.6, transformers-compat >= 0.5 && < 0.7 if flag(tagged) build-depends: tagged >= 0.7.3 && < 1 if flag(semigroups) build-depends: semigroups >= 0.8.3.1 && < 1 if impl(ghc<7.9) hs-source-dirs: old-src/ghc709 exposed-modules: Data.Bifunctor if impl(ghc<8.1) hs-source-dirs: old-src/ghc801 exposed-modules: Data.Bifoldable Data.Bitraversable if impl(ghc>=7.2) && impl(ghc<7.5) build-depends: ghc-prim == 0.2.0.0 exposed-modules: Data.Biapplicative Data.Bifunctor.Biff Data.Bifunctor.Clown Data.Bifunctor.Fix Data.Bifunctor.Flip Data.Bifunctor.Functor Data.Bifunctor.Join Data.Bifunctor.Joker Data.Bifunctor.Product Data.Bifunctor.Sum Data.Bifunctor.Tannen Data.Bifunctor.TH Data.Bifunctor.Wrapped other-modules: Data.Bifunctor.TH.Internal Paths_bifunctors ghc-options: -Wall test-suite bifunctors-spec type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs other-modules: BifunctorSpec ghc-options: -Wall build-tool-depends: hspec-discover:hspec-discover >= 1.8 build-depends: base >= 4 && < 5, bifunctors, hspec >= 1.8, QuickCheck >= 2 && < 3, template-haskell, transformers, transformers-compat
