bifunctors 5.4.2 → 5.6.3
raw patch · 24 files changed
Files
- .travis.yml +0/−114
- CHANGELOG.markdown +184/−0
- README.markdown +1/−1
- bifunctors.cabal +49/−41
- old-src/ghc709/Data/Bifunctor.hs +0/−193
- old-src/ghc801/Data/Bifoldable.hs +0/−494
- old-src/ghc801/Data/Bitraversable.hs +0/−329
- src/Data/Biapplicative.hs +204/−30
- src/Data/Bifunctor/Biap.hs +116/−0
- src/Data/Bifunctor/Biff.hs +43/−62
- src/Data/Bifunctor/Clown.hs +52/−59
- src/Data/Bifunctor/Fix.hs +27/−41
- src/Data/Bifunctor/Flip.hs +48/−39
- src/Data/Bifunctor/Functor.hs +2/−13
- src/Data/Bifunctor/Join.hs +32/−41
- src/Data/Bifunctor/Joker.hs +56/−58
- src/Data/Bifunctor/Product.hs +77/−54
- src/Data/Bifunctor/Sum.hs +45/−53
- src/Data/Bifunctor/TH.hs +1307/−1215
- src/Data/Bifunctor/TH/Internal.hs +103/−311
- src/Data/Bifunctor/Tannen.hs +42/−57
- src/Data/Bifunctor/Wrapped.hs +34/−61
- tests/BifunctorSpec.hs +228/−50
- tests/T89Spec.hs +21/−0
− .travis.yml
@@ -1,114 +0,0 @@-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis-language: c-sudo: false--cache:- directories:- - $HOME/.cabsnap- - $HOME/.cabal/packages--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar--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]}}-- allow_failures:- - env: CABALVER=1.18 GHCVER=7.0.4- - env: CABALVER=1.18 GHCVER=7.2.2- - env: CABALVER=head GHCVER=head--before_install:- - unset CC- - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH--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--# 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"--# EOF
CHANGELOG.markdown view
@@ -1,3 +1,187 @@+5.6.3 [2026.01.03]+------------------+* Allow building with `template-haskell-2.24.*` (GHC 9.14).+* Remove unused dependencies.++5.6.2 [2024.03.19]+------------------+* Support building with `template-haskell-2.22.*` (GHC 9.10).++5.6.1 [2023.03.13]+------------------+* Provide instances for the `Swap` and `Assoc` type classes from the `assoc`+ package. (These instances were previously defined in `assoc` itself, but they+ have been migrated over to `bifunctors` in tandem with the `assoc-1.1`+ release.)+* Only depend on `bifunctor-classes-compat` if building with GHC 8.0.++5.6 [2023.03.12]+----------------+* Drop support for GHC 7.10 and earlier.+* Move the `Data.Bifunctor`, `Data.Bifoldable`, and `Data.Bitraversable`+ compatibility modules to the new `bifunctor-classes-compat` package. For+ backwards compatibility, the `bifunctors` library re-exports+ `Data.Bifoldable` and `Data.Bitraversable` modules from+ `bifunctor-classes-compat` when building with GHC 8.0.++ If your library depends on `bifunctors` and compiles with pre-8.2+ versions of GHC, be warned that it may be possible to construct a+ build plan involving a pre-`5.6` version of `bifunctors` where:++ * Some of the `Bifunctor` instances come from+ `bifunctor-classes-compat`'s compatibility classes, and+ * Other `Bifunctor` instances come from `bifunctors`'s compatibility classes.++ These compatibility classes are distinct, so this could lead to build errors+ under certain conditions. Some possible ways to mitigate this risk include:++ * Drop support for GHC 8.0 and older in your library.+ * Require `bifunctors >= 5.6` in your library.+ * If neither of the options above are viable, then you can temporarily+ define instances for the old compatibility classes from `bifunctors` like+ so:++ ```hs+ -- For Bifunctor instances+ import qualified "bifunctor-classes-compat" Data.Bifunctor as BifunctorCompat+ #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,8,0)+ import qualified "bifunctors" Data.Bifunctor as Bifunctor+ #endif++ instance BifunctorCompat.Bifunctor MyType where ...++ #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,8,0)+ instance Bifunctor.Bifunctor MyType where ...+ #endif+ ```++ ```hs+ -- For Bifoldable and Bitraversable instances+ import qualified "bifunctor-classes-compat" Data.Bifoldable as BifoldableCompat+ import qualified "bifunctor-classes-compat" Data.Bitraversable as BitraversableCompat+ #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,10,0)+ import qualified "bifunctors" Data.Bifoldable as Bifoldable+ import qualified "bifunctors" Data.Bitraversable as Bitraversable+ #endif++ instance BifoldableCompat.Bifoldable MyType where ...+ instance BitraversableCompat.Bitraversable MyType where ...++ #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,10,0)+ instance Bifoldable.Bifoldable MyType where ...+ instance Bitraversable.Bitraversable MyType where ...+ #endif+ ```++ If your package does nothing but define instances of `Bifunctor` _et al._,+ you may consider replacing your `bifunctors` dependency with+ `bifunctor-classes-compat` to reduce your dependency footprint. If you do,+ it is strongly recommended that you bump your package's major version number+ so that your users are alerted to the details of the migration.+* Define a `Foldable1` instance for `Joker`, and define `Bifoldable1` instances+ for `Biff`, `Clown`, `Flip`, `Join`, `Joker`, `Product`, `Tannen`, and+ `WrappedBifunctor`. These instances were originally defined in the+ `semigroupoids` library, and they have now been migrated to `bifunctors` as+ a side effect of adapting to+ [this Core Libraries Proposal](https://github.com/haskell/core-libraries-committee/issues/9),+ which adds `Foldable1` and `Bifoldable1` to `base`.++5.5.15 [2023.02.27]+-------------------+* Support `th-abstraction-0.5.*`.++5.5.14 [2022.12.07]+-------------------+* Define `Functor`, `Foldable`, and `Traversable` instances for `Sum` and+ `Product`.++5.5.13 [2022.09.12]+-------------------+* Make the `Biapplicative` instances for tuples lazy, to match their `Bifunctor`+ instances.++5.5.12 [2022.05.07]+-------------------+* Backport an upstream GHC change which removes the default implementation of+ `bitraverse`. Per the discussion in+ https://github.com/haskell/core-libraries-committee/issues/47, this default+ implementation was completely broken, as attempting to use it would always+ result in an infinite loop.++5.5.11 [2021.04.30]+-------------------+* Allow building with `template-haskell-2.18` (GHC 9.2).++5.5.10 [2021.01.21]+-------------------+* Fix a bug in which `deriveBifoldable` could generate code that triggers+ `-Wunused-matches` warnings.++5.5.9 [2020.12.30]+------------------+* Explicitly mark modules as Safe or Trustworthy.++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`.++5.5.6 [2019.11.26]+------------------+* Add `Category`, `Arrow`, `ArrowChoice`, `ArrowLoop`, `ArrowZero`, and+ `ArrowPlus` instances for `Data.Bifunctor.Product`.++5.5.5 [2019.08.27]+------------------+* Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for data+ types in the `Data.Bifunctor.*` module namespace where possible. The+ operative phrase is "where possible" since many of these instances require+ the use of `Eq2`/`Ord2`/`Read2`/`Show2`, which are not available when+ built against `transformers-0.4.*`.++5.5.4 [2019.04.26]+------------------+* Support `th-abstraction-0.3` or later.+* Don't incur a `semigroup` dependency on recent GHCs.++5.5.3 [2018.07.04]+------------------+* Make `biliftA2` a class method of `Biapplicative`.+* Add the `traverseBia`, `sequenceBia`, and `traverseBiaWith` functions for+ traversing a `Traversable` container in a `Biapplicative`.+* Avoid incurring some dependencies when using recent GHCs.++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)
README.markdown view
@@ -1,7 +1,7 @@ bifunctors ========== -[](https://hackage.haskell.org/package/bifunctors) [](http://travis-ci.org/ekmett/bifunctors)+[](https://hackage.haskell.org/package/bifunctors) [](https://github.com/ekmett/bifunctors/actions?query=workflow%3AHaskell-CI) Contact Information -------------------
bifunctors.cabal view
@@ -1,8 +1,8 @@+cabal-version: 1.24 name: bifunctors category: Data, Functors-version: 5.4.2+version: 5.6.3 license: BSD3-cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -11,23 +11,30 @@ 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-extra-source-files: .travis.yml CHANGELOG.markdown README.markdown+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1+extra-source-files:+ 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@@ -39,35 +46,32 @@ 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.13,- transformers >= 0.2 && < 0.6,- transformers-compat >= 0.5 && < 0.6-- if flag(tagged)- build-depends: tagged >= 0.7.3 && < 1+ base >= 4.9 && < 5,+ assoc >= 1.1 && < 1.2,+ comonad >= 5.0.7 && < 6,+ containers >= 0.5.7.1 && < 0.9,+ template-haskell >= 2.11 && < 2.25,+ th-abstraction >= 0.4.2.0 && < 0.8 - if flag(semigroups)- build-depends: semigroups >= 0.8.3.1 && < 1+ if !impl(ghc >= 8.2)+ build-depends:+ bifunctor-classes-compat >= 0.1 && < 0.2,+ transformers-compat >= 0.6 && < 0.8 - if impl(ghc<7.9)- hs-source-dirs: old-src/ghc709- exposed-modules: Data.Bifunctor+ if flag(tagged)+ build-depends: tagged >= 0.8.6 && < 1 if impl(ghc<8.1)- hs-source-dirs: old-src/ghc801- exposed-modules:- Data.Bifoldable- Data.Bitraversable+ reexported-modules:+ Data.Bifoldable+ , Data.Bitraversable - if impl(ghc>=7.2) && impl(ghc<7.5)- build-depends: ghc-prim == 0.2.0.0+ if !impl(ghc >= 9.6)+ build-depends: foldable1-classes-compat >= 0.1 && < 0.2 exposed-modules: Data.Biapplicative+ Data.Bifunctor.Biap Data.Bifunctor.Biff Data.Bifunctor.Clown Data.Bifunctor.Fix@@ -83,23 +87,27 @@ other-modules: Data.Bifunctor.TH.Internal- Paths_bifunctors ghc-options: -Wall+ default-language: Haskell2010 + if impl(ghc >= 9.0)+ -- these flags may abort compilation with GHC-8.10+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+ ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode test-suite bifunctors-spec type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs- other-modules: BifunctorSpec+ other-modules: BifunctorSpec T89Spec 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, bifunctors, hspec >= 1.8,- QuickCheck >= 2 && < 3,- template-haskell,- transformers,- transformers-compat-+ QuickCheck >= 2 && < 3
− old-src/ghc709/Data/Bifunctor.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif--------------------------------------------------------------------------------- |--- Copyright : (C) 2008-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bifunctor- ( -- * Overview- --- -- Bifunctors extend the standard 'Functor' to two arguments-- -- * Examples- -- $examples- Bifunctor(..)- ) where--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-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (K1(..))-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif---- | Minimal definition either 'bimap' or 'first' and 'second'---- | Formally, the class 'Bifunctor' represents a bifunctor--- from @Hask@ -> @Hask@.------ Intuitively it is a bifunctor where both the first and second arguments are covariant.------ You can define a 'Bifunctor' by either defining 'bimap' or by defining both--- 'first' and 'second'.------ If you supply 'bimap', you should ensure that:------ @'bimap' 'id' 'id' ≡ 'id'@------ If you supply 'first' and 'second', ensure:------ @--- 'first' 'id' ≡ 'id'--- 'second' 'id' ≡ 'id'--- @------ If you supply both, you should also ensure:------ @'bimap' f g ≡ 'first' f '.' 'second' g@------ These ensure by parametricity:------ @--- 'bimap' (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i--- 'first' (f '.' g) ≡ 'first' f '.' 'first' g--- 'second' (f '.' g) ≡ 'second' f '.' 'second' g--- @-class Bifunctor p where- -- | Map over both arguments at the same time.- --- -- @'bimap' f g ≡ 'first' f '.' 'second' g@- bimap :: (a -> b) -> (c -> d) -> p a c -> p b d- bimap f g = first f . second g- {-# INLINE bimap #-}-- -- | Map covariantly over the first argument.- --- -- @'first' f ≡ 'bimap' f 'id'@- first :: (a -> b) -> p a c -> p b c- first f = bimap f id- {-# INLINE first #-}-- -- | Map covariantly over the second argument.- --- -- @'second' ≡ 'bimap' 'id'@- second :: (b -> c) -> p a b -> p a c- second = bimap id- {-# INLINE second #-}--#if __GLASGOW_HASKELL__ >= 708- {-# MINIMAL bimap | first, second #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-deriving instance Typeable Bifunctor-#endif--instance Bifunctor (,) where- 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)- {-# INLINE bimap #-}--instance Bifunctor ((,,,) x y) where- bimap f g ~(x, y, a, b) = (x, y, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,,) x y z) where- bimap f g ~(x, y, z, a, b) = (x, y, z, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,,,) x y z w) where- bimap f g ~(x, y, z, w, a, b) = (x, y, z, w, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,,,,) x y z w v) where- bimap f g ~(x, y, z, w, v, a, b) = (x, y, z, w, v, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor Either where- bimap f _ (Left a) = Left (f a)- bimap _ g (Right b) = Right (g b)- {-# INLINE bimap #-}--instance Bifunctor Const where- bimap f _ (Const a) = Const (f a)- {-# INLINE bimap #-}--instance Bifunctor Constant where- bimap f _ (Constant a) = Constant (f a)- {-# INLINE bimap #-}--#if __GLASGOW_HASKELL__ >= 702-instance Bifunctor (K1 i) where- bimap f _ (K1 c) = K1 (f c)- {-# INLINE bimap #-}-#endif--#ifdef MIN_VERSION_tagged-instance Bifunctor Tagged where- bimap _ g (Tagged b) = Tagged (g b)- {-# INLINE bimap #-}-#endif---- $examples------ ==== __Examples__------ While the standard 'Functor' instance for 'Either' is limited to mapping over 'Right' arguments,--- the 'Bifunctor' instance allows mapping over the 'Left', 'Right', or both arguments:------ > let x = Left "foo" :: Either String Integer------ In the case of 'first' and 'second', the function may or may not be applied:------ > first (++ "bar") x == Left "foobar"--- > second (+2) x == Left "foo"------ In the case of 'bimap', only one of the functions will be applied:------ > bimap (++ "bar") (+2) x == Left "foobar"------ The 'Bifunctor' instance for 2 element tuples allows mapping over one or both of the elements:------ > let x = ("foo",1)--- >--- > first (++ "bar") x == ("foobar", 1)--- > second (+2) x == ("foo", 3)--- > bimap (++ "bar") (+2) x == ("foobar", 3)
− old-src/ghc801/Data/Bifoldable.hs
@@ -1,494 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bifoldable- ( Bifoldable(..)- , bifoldr'- , bifoldr1- , bifoldrM- , bifoldl'- , bifoldl1- , bifoldlM- , bitraverse_- , bifor_- , bimapM_- , biforM_- , bimsum- , bisequenceA_- , bisequence_- , biasum- , biList- , binull- , bilength- , bielem- , bimaximum- , biminimum- , bisum- , biproduct- , biconcat- , biconcatMap- , biand- , bior- , biany- , biall- , bimaximumBy- , biminimumBy- , binotElem- , bifind- ) where--import Control.Applicative-import Control.Monad-import Data.Functor.Constant-import Data.Maybe (fromMaybe)-import Data.Monoid--#if MIN_VERSION_base(4,7,0)-import Data.Coerce-#else-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-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (K1(..))-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-import Data.Typeable-#endif---- | 'Bifoldable' identifies foldable structures with two different varieties--- of elements (as opposed to 'Foldable', which has one variety of element).--- Common examples are 'Either' and '(,)':------ > instance Bifoldable Either where--- > bifoldMap f _ (Left a) = f a--- > bifoldMap _ g (Right b) = g b--- >--- > instance Bifoldable (,) where--- > bifoldr f g z (a, b) = f a (g b z)------ A minimal 'Bifoldable' definition consists of either 'bifoldMap' or--- 'bifoldr'. When defining more than this minimal set, one should ensure--- that the following identities hold:------ @--- 'bifold' ≡ 'bifoldMap' 'id' 'id'--- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'--- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z--- @------ If the type is also a 'Bifunctor' instance, it should satisfy:------ > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g------ which implies that------ > 'bifoldMap' f g . 'bimap' h i ≡ 'bifoldMap' (f . h) (g . i)-class Bifoldable p where- -- | Combines the elements of a structure using a monoid.- --- -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@- bifold :: Monoid m => p m m -> m- bifold = bifoldMap id id- {-# INLINE bifold #-}-- -- | Combines the elements of a structure, given ways of mapping them to a- -- common monoid.- --- -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@- bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m- bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty- {-# INLINE bifoldMap #-}-- -- | Combines the elements of a structure in a right associative manner. Given- -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a- -- list of all elements of a structure in order, the following would hold:- --- -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@- bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c- bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z- {-# INLINE bifoldr #-}-- -- | Combines the elments of a structure in a left associative manner. Given a- -- hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a- -- list of all elements of a structure in order, the following would hold:- --- -- @'bifoldl' f g z ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@- --- -- Note that if you want an efficient left-fold, you probably want to use- -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not- -- force the "inner" results, resulting in a thunk chain which then must be- -- evaluated from the outside-in.- bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c- bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z- {-# INLINE bifoldl #-}--#if __GLASGOW_HASKELL__ >= 708- {-# MINIMAL bifoldr | bifoldMap #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-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- {-# INLINE bifoldMap #-}--instance Bifoldable Const where- bifoldMap f _ (Const a) = f a- {-# INLINE bifoldMap #-}--instance Bifoldable Constant where- bifoldMap f _ (Constant a) = f a- {-# INLINE bifoldMap #-}--#if __GLASGOW_HASKELL__ >= 702-instance Bifoldable (K1 i) where- bifoldMap f _ (K1 c) = f c- {-# INLINE bifoldMap #-}-#endif--instance Bifoldable ((,,) x) where- bifoldMap f g ~(_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,) x y) where- bifoldMap f g ~(_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,,) x y z) where- bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,,,) x y z w) where- bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,,,,) x y z w v) where- bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--#ifdef MIN_VERSION_tagged-instance Bifoldable Tagged where- bifoldMap _ g (Tagged b) = g b- {-# INLINE bifoldMap #-}-#endif--instance Bifoldable Either where- bifoldMap f _ (Left a) = f a- bifoldMap _ g (Right b) = g b- {-# INLINE bifoldMap #-}---- | As 'bifoldr', but strict in the result of the reduction functions at each--- step.-bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c-bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where- f' k x z = k $! f x z- g' k x z = k $! g x z-{-# INLINE bifoldr' #-}---- | A variant of 'bifoldr' that has no base case,--- and thus may only be applied to non-empty structures.-bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a-bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure")- (bifoldr mbf mbf Nothing xs)- where- mbf x m = Just (case m of- Nothing -> x- Just y -> f x y)-{-# INLINE bifoldr1 #-}---- | Right associative monadic bifold over a structure.-bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c-bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where- f' k x z = f x z >>= k- g' k x z = g x z >>= k-{-# INLINE bifoldrM #-}---- | As 'bifoldl', but strict in the result of the reduction functions at each--- step.------ This ensures that each step of the bifold is forced to weak head normal form--- before being applied, avoiding the collection of thunks that would otherwise--- occur. This is often what you want to strictly reduce a finite structure to--- a single, monolithic result (e.g., 'bilength').-bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a-bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where- f' x k z = k $! f z x- g' x k z = k $! g z x-{-# INLINE bifoldl' #-}---- | A variant of 'bifoldl' that has no base case,--- and thus may only be applied to non-empty structures.-bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a-bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure")- (bifoldl mbf mbf Nothing xs)- where- mbf m y = Just (case m of- Nothing -> y- Just x -> f x y)-{-# INLINe bifoldl1 #-}---- | Left associative monadic bifold over a structure.-bifoldlM :: (Bifoldable t, Monad m) => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a-bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where- f' x k z = f z x >>= k- g' x k z = g z x >>= k-{-# INLINE bifoldlM #-}---- | Map each element of a structure using one of two actions, evaluate these--- actions from left to right, and ignore the results. For a version that--- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'.-bitraverse_ :: (Bifoldable t, Applicative f) => (a -> f c) -> (b -> f d) -> t a b -> f ()-bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())-{-# INLINE bitraverse_ #-}---- | As 'bitraverse_', but with the structure as the primary argument. For a--- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'.------ >>> > bifor_ ('a', "bc") print (print . reverse)--- 'a'--- "cb"-bifor_ :: (Bifoldable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f ()-bifor_ t f g = bitraverse_ f g t-{-# INLINE bifor_ #-}---- | As 'Data.Bitraversable.bimapM', but ignores the results of the functions,--- merely performing the "actions".-bimapM_:: (Bifoldable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m ()-bimapM_ f g = bifoldr ((>>) . f) ((>>) . g) (return ())-{-# INLINE bimapM_ #-}---- | As 'bimapM_', but with the structure as the primary argument.-biforM_ :: (Bifoldable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m ()-biforM_ t f g = bimapM_ f g t-{-# INLINE biforM_ #-}---- | As 'Data.Bitraversable.bisequenceA', but ignores the results of the actions.-bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()-bisequenceA_ = bifoldr (*>) (*>) (pure ())-{-# INLINE bisequenceA_ #-}---- | Evaluate each action in the structure from left to right, and ignore the--- results. For a version that doesn't ignore the results, see--- 'Data.Bitraversable.bisequence'.-bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m ()-bisequence_ = bifoldr (>>) (>>) (return ())-{-# INLINE bisequence_ #-}---- | The sum of a collection of actions, generalizing 'biconcat'.-biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a-biasum = bifoldr (<|>) (<|>) empty-{-# INLINE biasum #-}---- | The sum of a collection of actions, generalizing 'biconcat'.-bimsum :: (Bifoldable t, MonadPlus m) => t (m a) (m a) -> m a-bimsum = bifoldr mplus mplus mzero-{-# INLINE bimsum #-}---- | Collects the list of elements of a structure, from left to right.-biList :: Bifoldable t => t a a -> [a]-biList = bifoldr (:) (:) []-{-# INLINE biList #-}---- | Test whether the structure is empty.-binull :: Bifoldable t => t a b -> Bool-binull = bifoldr (\_ _ -> False) (\_ _ -> False) True-{-# INLINE binull #-}---- | Returns the size/length of a finite structure as an 'Int'.-bilength :: Bifoldable t => t a b -> Int-bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0-{-# INLINE bilength #-}---- | Does the element occur in the structure?-bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool-bielem x = biany (== x) (== x)-{-# INLINE bielem #-}---- | Reduces a structure of lists to the concatenation of those lists.-biconcat :: Bifoldable t => t [a] [a] -> [a]-biconcat = bifold-{-# INLINE biconcat #-}--newtype Max a = Max {getMax :: Maybe a}-newtype Min a = Min {getMin :: Maybe a}--instance Ord a => Monoid (Max a) where- mempty = Max Nothing-- {-# INLINE mappend #-}- m `mappend` Max Nothing = m- Max Nothing `mappend` n = n- (Max m@(Just x)) `mappend` (Max n@(Just y))- | x >= y = Max m- | otherwise = Max n--instance Ord a => Monoid (Min a) where- mempty = Min Nothing-- {-# INLINE mappend #-}- m `mappend` Min Nothing = m- Min Nothing `mappend` n = n- (Min m@(Just x)) `mappend` (Min n@(Just y))- | x <= y = Min m- | otherwise = Min n---- | The largest element of a non-empty structure.-bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a-bimaximum = fromMaybe (error "bimaximum: empty structure") .- getMax . bifoldMap mj mj- where mj = Max #. (Just :: a -> Maybe a)-{-# INLINE bimaximum #-}---- | The least element of a non-empty structure.-biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a-biminimum = fromMaybe (error "biminimum: empty structure") .- getMin . bifoldMap mj mj- where mj = Min #. (Just :: a -> Maybe a)-{-# INLINE biminimum #-}---- | The 'bisum' function computes the sum of the numbers of a structure.-bisum :: (Bifoldable t, Num a) => t a a -> a-bisum = getSum #. bifoldMap Sum Sum-{-# INLINE bisum #-}---- | The 'biproduct' function computes the product of the numbers of a--- structure.-biproduct :: (Bifoldable t, Num a) => t a a -> a-biproduct = getProduct #. bifoldMap Product Product-{-# INLINE biproduct #-}---- | Given a means of mapping the elements of a structure to lists, computes the--- concatenation of all such lists in order.-biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c]-biconcatMap = bifoldMap-{-# INLINE biconcatMap #-}---- | 'biand' returns the conjunction of a container of Bools. For the--- result to be 'True', the container must be finite; 'False', however,--- results from a 'False' value finitely far from the left end.-biand :: Bifoldable t => t Bool Bool -> Bool-biand = getAll #. bifoldMap All All-{-# INLINE biand #-}---- | 'bior' returns the disjunction of a container of Bools. For the--- result to be 'False', the container must be finite; 'True', however,--- results from a 'True' value finitely far from the left end.-bior :: Bifoldable t => t Bool Bool -> Bool-bior = getAny #. bifoldMap Any Any-{-# INLINE bior #-}---- | Determines whether any element of the structure satisfies the appropriate--- predicate.-biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool-biany p q = getAny #. bifoldMap (Any . p) (Any . q)-{-# INLINE biany #-}---- | Determines whether all elements of the structure satisfy the appropriate--- predicate.-biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool-biall p q = getAll #. bifoldMap (All . p) (All . q)-{-# INLINE biall #-}---- | The largest element of a non-empty structure with respect to the--- given comparison function.-bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a-bimaximumBy cmp = bifoldr1 max'- where max' x y = case cmp x y of- GT -> x- _ -> y-{-# INLINE bimaximumBy #-}---- | The least element of a non-empty structure with respect to the--- given comparison function.-biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a-biminimumBy cmp = bifoldr1 min'- where min' x y = case cmp x y of- GT -> y- _ -> x-{-# INLINE biminimumBy #-}---- | 'binotElem' is the negation of 'bielem'.-binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool-binotElem x = not . bielem x-{-# INLINE binotElem #-}---- | The 'bifind' function takes a predicate and a structure and returns--- the leftmost element of the structure matching the predicate, or--- 'Nothing' if there is no such element.-bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a-bifind p = getFirst . bifoldMap finder finder- where finder x = First (if p x then Just x else Nothing)-{-# INLINE bifind #-}---- See Note [Function coercion]-#if MIN_VERSION_base(4,7,0)-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = coerce-#else-(#.) :: (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = unsafeCoerce-#endif-{-# INLINE (#.) #-}--{--Note [Function coercion]-~~~~~~~~~~~~~~~~~~~~~~~~--Several functions here use (#.) instead of (.) to avoid potential efficiency-problems relating to #7542. The problem, in a nutshell:--If N is a newtype constructor, then N x will always have the same-representation as x (something similar applies for a newtype deconstructor).-However, if f is a function,--N . f = \x -> N (f x)--This looks almost the same as f, but the eta expansion lifts it--the lhs could-be _|_, but the rhs never is. This can lead to very inefficient code. Thus we-steal a technique from Shachaf and Edward Kmett and adapt it to the current-(rather clean) setting. Instead of using N . f, we use N .## f, which is-just--coerce f `asTypeOf` (N . f)--That is, we just *pretend* that f has the right type, and thanks to the safety-of coerce, the type checker guarantees that nothing really goes wrong. We still-have to be a bit careful, though: remember that #. completely ignores the-*value* of its left operand.--}
− old-src/ghc801/Data/Bitraversable.hs
@@ -1,329 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif--#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif--------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bitraversable- ( Bitraversable(..)- , bisequenceA- , bisequence- , bimapM- , bifor- , biforM- , bimapAccumL- , bimapAccumR- , bimapDefault- , bifoldMapDefault- ) where--import Control.Applicative-import Control.Monad.Trans.Instances ()-import Data.Bifunctor-import Data.Bifoldable-import Data.Functor.Constant-import Data.Functor.Identity-import Data.Orphans ()--#if MIN_VERSION_base(4,7,0)-import Data.Coerce (coerce)-#else-import Unsafe.Coerce (unsafeCoerce)-#endif--#if !(MIN_VERSION_base(4,8,0))-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-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (K1(..))-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-import Data.Typeable-#endif---- | 'Bitraversable' identifies bifunctorial data structures whose elements can--- be traversed in order, performing 'Applicative' or 'Monad' actions at each--- element, and collecting a result structure with the same shape.------ As opposed to 'Traversable' data structures, which have one variety of--- element on which an action can be performed, 'Bitraversable' data structures--- have two such varieties of elements.------ A definition of 'bitraverse' must satisfy the following laws:------ [/naturality/]--- @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@--- for every applicative transformation @t@------ [/identity/]--- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@------ [/composition/]--- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2--- ≡ 'traverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@------ where an /applicative transformation/ is a function------ @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@------ preserving the 'Applicative' operations:------ @--- t ('pure' x) = 'pure' x--- t (f '<*>' x) = t f '<*>' t x--- @------ and the identity functor 'Identity' and composition functors 'Compose' are--- defined as------ > newtype Identity a = Identity { runIdentity :: a }--- >--- > instance Functor Identity where--- > fmap f (Identity x) = Identity (f x)--- >--- > instance Applicative Identity where--- > pure = Identity--- > Identity f <*> Identity x = Identity (f x)--- >--- > newtype Compose f g a = Compose (f (g a))--- >--- > instance (Functor f, Functor g) => Functor (Compose f g) where--- > fmap f (Compose x) = Compose (fmap (fmap f) x)--- >--- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where--- > pure = Compose . pure . pure--- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)------ Some simple examples are 'Either' and '(,)':------ > instance Bitraversable Either where--- > bitraverse f _ (Left x) = Left <$> f x--- > bitraverse _ g (Right y) = Right <$> g y--- >--- > instance Bitraversable (,) where--- > bitraverse f g (x, y) = (,) <$> f x <*> g y------ 'Bitraversable' relates to its superclasses in the following ways:------ @--- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)--- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)--- @------ These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.-class (Bifunctor t, Bifoldable t) => Bitraversable t where- -- | Evaluates the relevant functions at each element in the structure, running- -- the action, and builds a new structure with the same shape, using the- -- elements produced from sequencing the actions.- --- -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@- --- -- For a version that ignores the results, see 'bitraverse_'.- bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)- bitraverse f g = bisequenceA . bimap f g- {-# INLINE bitraverse #-}----- | Sequences all the actions in a structure, building a new structure with the--- same shape using the results of the actions. For a version that ignores the--- results, see 'bisequenceA_'.------ @'bisequenceA' ≡ 'bitraverse' 'id' 'id'@-bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)-bisequenceA = bitraverse id id-{-# INLINE bisequenceA #-}---- | As 'bitraverse', but uses evidence that @m@ is a 'Monad' rather than an--- 'Applicative'. For a version that ignores the results, see 'bimapM_'.------ @--- 'bimapM' f g ≡ 'bisequence' . 'bimap' f g--- 'bimapM' f g ≡ 'unwrapMonad' . 'bitraverse' ('WrapMonad' . f) ('WrapMonad' . g)--- @-bimapM :: (Bitraversable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m (t c d)-bimapM f g = unwrapMonad . bitraverse (WrapMonad . f) (WrapMonad . g)-{-# INLINE bimapM #-}---- | As 'bisequenceA', but uses evidence that @m@ is a 'Monad' rather than an--- 'Applicative'. For a version that ignores the results, see 'bisequence_'.------ @--- 'bisequence' ≡ 'bimapM' 'id' 'id'--- 'bisequence' ≡ 'unwrapMonad' . 'bisequenceA' . 'bimap' 'WrapMonad' 'WrapMonad'--- @-bisequence :: (Bitraversable t, Monad m) => t (m a) (m b) -> m (t a b)-bisequence = bimapM id id-{-# INLINE bisequence #-}--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-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- {-# INLINE bitraverse #-}--instance Bitraversable ((,,) x) where- bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,) x y) where- bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,,) x y z) where- bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,,,) x y z w) where- bitraverse f g ~(x, y, z, w, a, b) = (,,,,,) x y z w <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,,,,) x y z w v) where- bitraverse f g ~(x, y, z, w, v, a, b) = (,,,,,,) x y z w v <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable Either where- bitraverse f _ (Left a) = Left <$> f a- bitraverse _ g (Right b) = Right <$> g b- {-# INLINE bitraverse #-}--instance Bitraversable Const where- bitraverse f _ (Const a) = Const <$> f a- {-# INLINE bitraverse #-}--instance Bitraversable Constant where- bitraverse f _ (Constant a) = Constant <$> f a- {-# INLINE bitraverse #-}--#if __GLASGOW_HASKELL__ >= 702-instance Bitraversable (K1 i) where- bitraverse f _ (K1 c) = K1 <$> f c- {-# INLINE bitraverse #-}-#endif--#ifdef MIN_VERSION_tagged-instance Bitraversable Tagged where- bitraverse _ g (Tagged b) = Tagged <$> g b- {-# INLINE bitraverse #-}-#endif---- | 'bifor' is 'bitraverse' with the structure as the first argument. For a--- version that ignores the results, see 'bifor_'.-bifor :: (Bitraversable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)-bifor t f g = bitraverse f g t-{-# INLINE bifor #-}---- | 'biforM' is 'bimapM' with the structure as the first argument. For a--- version that ignores the results, see 'biforM_'.-biforM :: (Bitraversable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m (t c d)-biforM t f g = bimapM f g t-{-# INLINE biforM #-}---- | left-to-right state transformer-newtype StateL s a = StateL { runStateL :: s -> (s, a) }--instance Functor (StateL s) where- fmap f (StateL k) = StateL $ \ s ->- let (s', v) = k s in (s', f v)- {-# INLINE fmap #-}--instance Applicative (StateL s) where- pure x = StateL (\ s -> (s, x))- {-# INLINE pure #-}- StateL kf <*> StateL kv = StateL $ \ s ->- let (s', f) = kf s- (s'', v) = kv s'- in (s'', f v)- {-# INLINE (<*>) #-}---- | The 'bimapAccumL' function behaves like a combination of 'bimap' and--- 'bifoldl'; it traverses a structure from left to right, threading a state--- of type @a@ and using the given actions to compute new elements for the--- structure.-bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)-bimapAccumL f g s t = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s-{-# INLINE bimapAccumL #-}---- | right-to-left state transformer-newtype StateR s a = StateR { runStateR :: s -> (s, a) }--instance Functor (StateR s) where- fmap f (StateR k) = StateR $ \ s ->- let (s', v) = k s in (s', f v)- {-# INLINE fmap #-}--instance Applicative (StateR s) where- pure x = StateR (\ s -> (s, x))- {-# INLINE pure #-}- StateR kf <*> StateR kv = StateR $ \ s ->- let (s', v) = kv s- (s'', f) = kf s'- in (s'', f v)- {-# INLINE (<*>) #-}---- | The 'bimapAccumR' function behaves like a combination of 'bimap' and--- 'bifoldl'; it traverses a structure from right to left, threading a state--- of type @a@ and using the given actions to compute new elements for the--- structure.-bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)-bimapAccumR f g s t = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s-{-# INLINE bimapAccumR #-}---- | A default definition of 'bimap' in terms of the 'Bitraversable' operations.------ @'bimapDefault' f g ≡--- 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@-bimapDefault :: forall t a b c d . Bitraversable t- => (a -> b) -> (c -> d) -> t a c -> t b d-bimapDefault = coerce- (bitraverse :: (a -> Identity b)- -> (c -> Identity d) -> t a c -> Identity (t b d))-{-# INLINE bimapDefault #-}---- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' operations.------ @'bifoldMapDefault' f g ≡--- 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@-bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)- => (a -> m) -> (b -> m) -> t a b -> m-bifoldMapDefault = coerce- (bitraverse :: (a -> Const m ())- -> (b -> Const m ()) -> t a b -> Const m (t () ()))-{-# INLINE bifoldMapDefault #-}--#if !(MIN_VERSION_base(4,7,0))-coerce :: a -> b-coerce = unsafeCoerce-#endif
src/Data/Biapplicative.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}-#endif+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-} -#ifndef MIN_VERSION_semigroups-#define MIN_VERSION_semigroups(x,y,z) 0-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett@@ -22,21 +19,18 @@ Biapplicative(..) , (<<$>>) , (<<**>>)- , biliftA2 , biliftA3+ , traverseBia+ , sequenceBia+ , traverseBiaWith , module Data.Bifunctor ) where import Control.Applicative import Data.Bifunctor--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2)+import Data.Functor.Identity import Data.Semigroup (Arg(..))-#endif+import GHC.Exts (inline) #ifdef MIN_VERSION_tagged import Data.Tagged@@ -48,16 +42,24 @@ {-# INLINE (<<$>>) #-} class Bifunctor p => Biapplicative p where+ {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-} bipure :: a -> b -> p a b (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d+ (<<*>>) = biliftA2 id id+ {-# INLINE (<<*>>) #-} + -- | Lift binary functions+ biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f+ biliftA2 f g a b = bimap f g <<$>> a <<*>> b+ {-# INLINE biliftA2 #-}+ -- | -- @ -- a '*>>' b ≡ 'bimap' ('const' 'id') ('const' 'id') '<<$>>' a '<<*>>' b -- @ (*>>) :: p a b -> p c d -> p c d- a *>> b = bimap (const id) (const id) <<$>> a <<*>> b+ a *>> b = biliftA2 (const id) (const id) a b {-# INLINE (*>>) #-} -- |@@ -65,65 +67,237 @@ -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b -- @ (<<*) :: p a b -> p c d -> p a b- a <<* b = bimap const const <<$>> a <<*>> b+ a <<* b = biliftA2 const const a b {-# INLINE (<<*) #-} (<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d (<<**>>) = biliftA2 (flip id) (flip id) {-# INLINE (<<**>>) #-} --- | Lift binary functions-biliftA2 :: Biapplicative w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f-biliftA2 f g a b = bimap f g <<$>> a <<*>> b-{-# INLINE biliftA2 #-} -- | Lift ternary functions biliftA3 :: Biapplicative w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h-biliftA3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c+biliftA3 f g a b c = biliftA2 f g a b <<*>> c {-# INLINE biliftA3 #-} +-- | Traverse a 'Traversable' container in a 'Biapplicative'.+--+-- 'traverseBia' satisfies the following properties:+--+-- [/Pairing/]+--+-- @'traverseBia' (,) t = (t, t)@+--+-- [/Composition/]+--+-- @'traverseBia' ('Data.Bifunctor.Biff.Biff' . 'bimap' g h . f) = 'Data.Bifunctor.Biff.Biff' . 'bimap' ('traverse' g) ('traverse' h) . 'traverseBia' f@+--+-- @'traverseBia' ('Data.Bifunctor.Tannen.Tannen' . 'fmap' f . g) = 'Data.Bifunctor.Tannen.Tannen' . 'fmap' ('traverseBia' f) . 'traverse' g@+--+-- [/Naturality/]+--+-- @ t . 'traverseBia' f = 'traverseBia' (t . f) @+--+-- for every biapplicative transformation @t@.+--+-- A /biapplicative transformation/ from a 'Biapplicative' @P@ to a 'Biapplicative' @Q@+-- is a function+--+-- @t :: P a b -> Q a b@+--+-- preserving the 'Biapplicative' operations. That is,+--+-- * @t ('bipure' x y) = 'bipure' x y@+--+-- * @t (x '<<*>>' y) = t x '<<*>>' t y@+--+-- === Performance note+--+-- 'traverseBia' is fairly efficient, and uses compiler rewrite rules+-- to be even more efficient for a few important types like @[]@. However,+-- if performance is critical, you might consider writing a container-specific+-- implementation.+traverseBia :: (Traversable t, Biapplicative p)+ => (a -> p b c) -> t a -> p (t b) (t c)+traverseBia = inline (traverseBiaWith traverse)+-- We explicitly inline traverseBiaWith because it seems likely to help+-- specialization. I'm not much of an expert at the inlining business,+-- so I won't mind if someone else decides to do this differently.++-- We use a staged INLINABLE so we can rewrite traverseBia to specialized+-- versions for a few important types.+{-# INLINABLE [1] traverseBia #-}++-- | Perform all the 'Biapplicative' actions in a 'Traversable' container+-- and produce a container with all the results.+--+-- @+-- sequenceBia = 'traverseBia' id+-- @+sequenceBia :: (Traversable t, Biapplicative p)+ => t (p b c) -> p (t b) (t c)+sequenceBia = inline (traverseBia id)+{-# INLINABLE sequenceBia #-}++-- | A version of 'traverseBia' that doesn't care how the traversal is+-- done.+--+-- @+-- 'traverseBia' = traverseBiaWith traverse+-- @+traverseBiaWith :: forall p a b c s t. Biapplicative p+ => (forall f x. Applicative f => (a -> f x) -> s -> f (t x))+ -> (a -> p b c) -> s -> p (t b) (t c)+traverseBiaWith trav p s = smash p (trav One s)+{-# INLINABLE traverseBiaWith #-}++smash :: forall p t a b c. Biapplicative p+ => (a -> p b c)+ -> (forall x. Mag a x (t x))+ -> p (t b) (t c)+smash p m = go m m+ where+ go :: forall x y. Mag a b x -> Mag a c y -> p x y+ go (Pure t) (Pure u) = bipure t u+ 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) = biliftA2 f g (go xs zs) (go ys ws)+#endif+ go (One x) (One _) = p x+ go _ _ = impossibleError+{-# INLINABLE smash #-}++-- Let's not end up with a bunch of CallStack junk in the smash+-- unfolding.+impossibleError :: a+impossibleError = error "Impossible: the arguments are always the same."++-- This is used to reify a traversal for 'traverseBia'. It's a somewhat+-- bogus 'Functor' and 'Applicative' closely related to 'Magma' from the+-- @lens@ package. Valid traversals don't use (<$), (<*), or (*>), so+-- we leave them out. We offer all the rest of the Functor and Applicative+-- operations to improve performance: we generally want to keep the structure+-- as small as possible. We might even consider using RULES to widen lifts+-- when we can:+--+-- liftA2 f x y <*> z ==> liftA3 f x y z,+--+-- etc., up to the pointer tagging limit. But we do need to be careful. I don't+-- *think* GHC will ever inline the traversal into the go function (because that+-- would duplicate work), but if it did, and if different RULES fired for the+-- two copies, everything would break horribly.+--+-- Note: if it's necessary for some reason, we *could* relax GADTs to+-- ExistentialQuantification by changing the type of One to+--+-- One :: (b -> c) -> a -> Mag a b c+--+-- where the function will always end up being id. But we allocate a *lot*+-- of One constructors, so this would definitely be bad for performance.+data Mag a b t where+ Pure :: t -> Mag a b t+ Map :: (x -> t) -> Mag a b x -> Mag a b t+ Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u+#if MIN_VERSION_base(4,10,0)+ LiftA2 :: (t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v+#endif+ One :: a -> Mag a b b++instance Functor (Mag a b) where+ fmap = Map++instance Applicative (Mag a b) where+ pure = Pure+ (<*>) = Ap+#if MIN_VERSION_base(4,10,0)+ liftA2 = LiftA2+#endif++-- Rewrite rules for traversing a few important types. These avoid the overhead+-- of allocating and matching on a Mag.+{-# RULES+"traverseBia/list" forall f t. traverseBia f t = traverseBiaList f t+"traverseBia/Maybe" forall f t. traverseBia f t = traverseBiaMaybe f t+"traverseBia/Either" forall f t. traverseBia f t = traverseBiaEither f t+"traverseBia/Identity" forall f t. traverseBia f t = traverseBiaIdentity f t+"traverseBia/Const" forall f t. traverseBia f t = traverseBiaConst f t+"traverseBia/Pair" forall f t. traverseBia f t = traverseBiaPair f t+ #-}++traverseBiaList :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]+traverseBiaList f = foldr go (bipure [] [])+ where+ go x r = biliftA2 (:) (:) (f x) r++traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c)+traverseBiaMaybe _f Nothing = bipure Nothing Nothing+traverseBiaMaybe f (Just x) = bimap Just Just (f x)++traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c)+traverseBiaEither f (Right x) = bimap Right Right (f x)+traverseBiaEither _f (Left (e :: e)) = bipure m m+ where+ m :: Either e x+ m = Left e++traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c)+traverseBiaIdentity f (Identity x) = bimap Identity Identity (f x)++traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c)+traverseBiaConst _f (Const x) = bipure (Const x) (Const x)++traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c)+traverseBiaPair f (x,y) = bimap ((,) x) ((,) x) (f y)++----------------------------------------------+--+-- Instances+ instance Biapplicative (,) where bipure = (,) {-# INLINE bipure #-}- (f, g) <<*>> (a, b) = (f a, g b)+ ~(f, g) <<*>> ~(a, b) = (f a, g b) {-# INLINE (<<*>>) #-}+ 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 #-} Arg f g <<*>> Arg a b = Arg (f a) (g b) {-# INLINE (<<*>>) #-}-#endif+ biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b)+ {-# INLINE biliftA2 #-} instance Monoid x => Biapplicative ((,,) x) where bipure = (,,) mempty {-# INLINE bipure #-}- (x, f, g) <<*>> (x', a, b) = (mappend x x', f a, g b)+ ~(x, f, g) <<*>> ~(x', a, b) = (mappend x x', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y) => Biapplicative ((,,,) x y) where bipure = (,,,) mempty mempty {-# INLINE bipure #-}- (x, y, f, g) <<*>> (x', y', a, b) = (mappend x x', mappend y y', f a, g b)+ ~(x, y, f, g) <<*>> ~(x', y', a, b) = (mappend x x', mappend y y', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z) => Biapplicative ((,,,,) x y z) where bipure = (,,,,) mempty mempty mempty {-# INLINE bipure #-}- (x, y, z, f, g) <<*>> (x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b)+ ~(x, y, z, f, g) <<*>> ~(x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z, Monoid w) => Biapplicative ((,,,,,) x y z w) where bipure = (,,,,,) mempty mempty mempty mempty {-# INLINE bipure #-}- (x, y, z, w, f, g) <<*>> (x', y', z', w', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', f a, g b)+ ~(x, y, z, w, f, g) <<*>> ~(x', y', z', w', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Biapplicative ((,,,,,,) x y z w v) where bipure = (,,,,,,) mempty mempty mempty mempty mempty {-# INLINE bipure #-}- (x, y, z, w, v, f, g) <<*>> (x', y', z', w', v', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', mappend v v', f a, g b)+ ~(x, y, z, w, v, f, g) <<*>> ~(x', y', z', w', v', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', mappend v v', f a, g b) {-# INLINE (<<*>>) #-} #ifdef MIN_VERSION_tagged
+ src/Data/Bifunctor/Biap.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- This module uses GND+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2016 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Data.Bifunctor.Biap+ ( Biap(..)+ ) where++import Control.Applicative+import Control.Monad+import qualified Control.Monad.Fail as Fail (MonadFail)+import Data.Biapplicative+import Data.Bifoldable+import Data.Bitraversable+import Data.Functor.Classes+import qualified Data.Semigroup as S+import GHC.Generics++-- | Pointwise lifting of a class over two arguments, using+-- 'Biapplicative'.+--+-- Classes that can be lifted include 'Monoid', 'Num' and+-- 'Bounded'. Each method of those classes can be defined as lifting+-- themselves over each argument of 'Biapplicative'.+--+-- @+-- mempty = bipure mempty mempty+-- minBound = bipure minBound minBound+-- maxBound = bipure maxBound maxBound+-- fromInteger n = bipure (fromInteger n) (fromInteger n)+--+-- negate = bimap negate negate+--+-- (+) = biliftA2 (+) (+)+-- (<>) = biliftA2 (<>) (<>)+-- @+--+-- 'Biap' is to 'Biapplicative' as 'Data.Monoid.Ap' is to+-- 'Applicative'.+--+-- 'Biap' can be used with @DerivingVia@ to derive a numeric instance+-- for pairs:+--+-- @+-- newtype Numpair a = Np (a, a)+-- deriving (S.Semigroup, Monoid, Num, Bounded)+-- via Biap (,) a a+-- @+--+newtype Biap bi a b = Biap { getBiap :: bi a b }+ deriving ( Eq+ , Ord+ , Show+ , Read+ , Enum+ , Functor+ , Foldable+ , Traversable+ , Alternative+ , Applicative+ , Generic+ , Generic1+ , Monad+ , Fail.MonadFail+ , MonadPlus+ , Eq1+ , Ord1+ , Bifunctor+ , Biapplicative+ , Bifoldable+ , Eq2+ , Ord2+ )++instance Bitraversable bi => Bitraversable (Biap bi) where+ bitraverse f g (Biap as) = Biap <$> bitraverse f g as++instance (Biapplicative bi, S.Semigroup a, S.Semigroup b) => S.Semigroup (Biap bi a b) where+ (<>) = biliftA2 (S.<>) (S.<>)++instance (Biapplicative bi, Monoid a, Monoid b) => Monoid (Biap bi a b) where+ mempty = bipure mempty mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = biliftA2 mappend mappend+#endif++instance (Biapplicative bi, Bounded a, Bounded b) => Bounded (Biap bi a b) where+ minBound = bipure minBound minBound+ maxBound = bipure maxBound maxBound++instance (Biapplicative bi, Num a, Num b) => Num (Biap bi a b) where+ (+) = biliftA2 (+) (+)+ (*) = biliftA2 (*) (*)++ negate = bimap negate negate+ abs = bimap abs abs+ signum = bimap signum signum++ fromInteger n = bipure (fromInteger n) (fromInteger n)
src/Data/Bifunctor/Biff.hs view
@@ -1,25 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif- ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett@@ -34,64 +21,50 @@ ( Biff(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..))+import Data.Bifunctor.Swap (Swap (..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Foldable1 (Foldable1(..))+import Data.Functor.Classes import GHC.Generics-#endif -- | Compose two 'Functor's on the inside of a 'Bifunctor'. newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable-#endif- )-#if __GLASGOW_HASKELL__ >= 702-# if __GLASGOW_HASKELL__ >= 708+ deriving (Eq, Ord, Show, Read, Generic) deriving instance Functor (p (f a)) => Generic1 (Biff p f g a)-# else-data BiffMetaData-data BiffMetaCons-data BiffMetaSel -instance Datatype BiffMetaData where- datatypeName = const "Biff"- moduleName = const "Data.Bifunctor.Biff"+instance (Eq2 p, Eq1 f, Eq1 g, Eq a) => Eq1 (Biff p f g a) where+ liftEq = liftEq2 (==)+instance (Eq2 p, Eq1 f, Eq1 g) => Eq2 (Biff p f g) where+ liftEq2 f g (Biff x) (Biff y) = liftEq2 (liftEq f) (liftEq g) x y -instance Constructor BiffMetaCons where- conName = const "Biff"- conIsRecord = const True+instance (Ord2 p, Ord1 f, Ord1 g, Ord a) => Ord1 (Biff p f g a) where+ liftCompare = liftCompare2 compare+instance (Ord2 p, Ord1 f, Ord1 g) => Ord2 (Biff p f g) where+ liftCompare2 f g (Biff x) (Biff y) = liftCompare2 (liftCompare f) (liftCompare g) x y -instance Selector BiffMetaSel where- selName = const "runBiff"+instance (Read2 p, Read1 f, Read1 g, Read a) => Read1 (Biff p f g a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Read2 p, Read1 f, Read1 g) => Read2 (Biff p f g) where+ liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do+ ("Biff", s1) <- lex s0+ ("{", s2) <- lex s1+ ("runBiff", s3) <- lex s2+ (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1)+ (liftReadsPrec rp2 rl2) (liftReadList rp2 rl2) 0 s3+ ("}", s5) <- lex s4+ return (Biff x, s5) -instance Functor (p (f a)) => Generic1 (Biff p f g a) where- type Rep1 (Biff p f g a) = D1 BiffMetaData (C1 BiffMetaCons- (S1 BiffMetaSel (p (f a) :.: Rec1 g)))- from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runBiff- to1 = Biff . fmap unRec1 . unComp1 . unM1 . unM1 . unM1-# endif-#endif+instance (Show2 p, Show1 f, Show1 g, Show a) => Show1 (Biff p f g a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance (Show2 p, Show1 f, Show1 g) => Show2 (Biff p f g) where+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (Biff x) = showParen (p > 10) $+ showString "Biff {runBiff = "+ . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1)+ (liftShowsPrec sp2 sl2) (liftShowList sp2 sl2) 0 x+ . showChar '}' instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where first f = Biff . first (fmap f) . runBiff@@ -120,6 +93,10 @@ bifoldMap f g = bifoldMap (foldMap f) (foldMap g) . runBiff {-# INLINE bifoldMap #-} +instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where+ bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff+ {-# INLINE bifoldMap1 #-}+ instance (Bitraversable p, Traversable g) => Traversable (Biff p f g a) where traverse f = fmap Biff . bitraverse pure (traverse f) . runBiff {-# INLINE traverse #-}@@ -127,3 +104,7 @@ instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (Biff p f g) where bitraverse f g = fmap Biff . bitraverse (traverse f) (traverse g) . runBiff {-# INLINE bitraverse #-}++-- | @since 5.6.1+instance (f ~ g, Functor f, Swap p) => Swap (Biff p f g) where+ swap = Biff . swap . runBiff
src/Data/Bifunctor/Clown.hs view
@@ -1,21 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -33,66 +20,68 @@ ( Clown(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Foldable1 (Foldable1(..))+import Data.Functor.Classes import GHC.Generics-#endif -- | Make a 'Functor' over the first argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Clown f a b = Clown { runClown :: f a }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )+ deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data ClownMetaData-data ClownMetaCons-data ClownMetaSel+instance (Eq1 f, Eq a) => Eq1 (Clown f a) where+ liftEq = liftEq2 (==)+instance Eq1 f => Eq2 (Clown f) where+ liftEq2 f _ = eqClown (liftEq f) -instance Datatype ClownMetaData where- datatypeName _ = "Clown"- moduleName _ = "Data.Bifunctor.Clown"+instance (Ord1 f, Ord a) => Ord1 (Clown f a) where+ liftCompare = liftCompare2 compare+instance Ord1 f => Ord2 (Clown f) where+ liftCompare2 f _ = compareClown (liftCompare f) -instance Constructor ClownMetaCons where- conName _ = "Clown"- conIsRecord _ = True+instance (Read1 f, Read a) => Read1 (Clown f a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance Read1 f => Read2 (Clown f) where+ liftReadsPrec2 rp1 rl1 _ _ = readsPrecClown (liftReadsPrec rp1 rl1) -instance Selector ClownMetaSel where- selName _ = "runClown"+instance (Show1 f, Show a) => Show1 (Clown f a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance Show1 f => Show2 (Clown f) where+ liftShowsPrec2 sp1 sl1 _ _ = showsPrecClown (liftShowsPrec sp1 sl1) -instance Generic1 (Clown f a) where- type Rep1 (Clown f a) = D1 ClownMetaData (C1 ClownMetaCons- (S1 ClownMetaSel (Rec0 (f a))))- from1 = M1 . M1 . M1 . K1 . runClown- to1 = Clown . unK1 . unM1 . unM1 . unM1-#endif+eqClown :: (f a1 -> f a2 -> Bool)+ -> Clown f a1 b1 -> Clown f a2 b2 -> Bool+eqClown eqA (Clown x) (Clown y) = eqA x y +compareClown :: (f a1 -> f a2 -> Ordering)+ -> Clown f a1 b1 -> Clown f a2 b2 -> Ordering+compareClown compareA (Clown x) (Clown y) = compareA x y++readsPrecClown :: (Int -> ReadS (f a))+ -> Int -> ReadS (Clown f a b)+readsPrecClown rpA p =+ readParen (p > 10) $ \s0 -> do+ ("Clown", s1) <- lex s0+ ("{", s2) <- lex s1+ ("runClown", s3) <- lex s2+ (x, s4) <- rpA 0 s3+ ("}", s5) <- lex s4+ return (Clown x, s5)++showsPrecClown :: (Int -> f a -> ShowS)+ -> Int -> Clown f a b -> ShowS+showsPrecClown spA p (Clown x) =+ showParen (p > 10) $+ showString "Clown {runClown = "+ . spA 0 x+ . showChar '}'+ instance Functor f => Bifunctor (Clown f) where first f = Clown . fmap f . runClown {-# INLINE first #-}@@ -115,6 +104,10 @@ instance Foldable f => Bifoldable (Clown f) where bifoldMap f _ = foldMap f . runClown {-# INLINE bifoldMap #-}++instance Foldable1 f => Bifoldable1 (Clown f) where+ bifoldMap1 f _ = foldMap1 f . runClown+ {-# INLINE bifoldMap1 #-} instance Foldable (Clown f a) where foldMap _ = mempty
src/Data/Bifunctor/Fix.hs view
@@ -1,23 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif- ----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Fix@@ -33,44 +20,43 @@ ( Fix(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Functor.Classes import GHC.Generics-#endif -- | Greatest fixpoint of a 'Bifunctor' (a 'Functor' over the first argument with zipping). newtype Fix p a = In { out :: p (Fix p a) a }- deriving- (-#if __GLASGOW_HASKELL__ >= 702- Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable-#endif- )+ deriving Generic deriving instance Eq (p (Fix p a) a) => Eq (Fix p a) deriving instance Ord (p (Fix p a) a) => Ord (Fix p a) deriving instance Show (p (Fix p a) a) => Show (Fix p a) deriving instance Read (p (Fix p a) a) => Read (Fix p a) +instance Eq2 p => Eq1 (Fix p) where+ liftEq f (In x) (In y) = liftEq2 (liftEq f) f x y++instance Ord2 p => Ord1 (Fix p) where+ liftCompare f (In x) (In y) = liftCompare2 (liftCompare f) f x y++instance Read2 p => Read1 (Fix p) where+ liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do+ ("In", s1) <- lex s0+ ("{", s2) <- lex s1+ ("out", s3) <- lex s2+ (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1)+ rp1 rl1 0 s3+ ("}", s5) <- lex s4+ return (In x, s5)++instance Show2 p => Show1 (Fix p) where+ liftShowsPrec sp1 sl1 p (In x) = showParen (p > 10) $+ showString "In {out = "+ . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1)+ sp1 sl1 0 x+ . showChar '}' instance Bifunctor p => Functor (Fix p) where fmap f (In p) = In (bimap (fmap f) f p)
src/Data/Bifunctor/Flip.hs view
@@ -1,19 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- |@@ -30,40 +17,49 @@ ( Flip(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bifunctor.Functor+import Data.Bifunctor.Swap (Swap (..))+import Data.Bifunctor.Assoc (Assoc (..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Functor.Classes import GHC.Generics-#endif -- | Make a 'Bifunctor' flipping the arguments of a 'Bifunctor'. newtype Flip p a b = Flip { runFlip :: p b a }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable-#endif- )+ deriving (Eq, Ord, Show, Read, Generic) +instance (Eq2 p, Eq a) => Eq1 (Flip p a) where+ liftEq = liftEq2 (==)+instance Eq2 p => Eq2 (Flip p) where+ liftEq2 f g (Flip x) (Flip y) = liftEq2 g f x y++instance (Ord2 p, Ord a) => Ord1 (Flip p a) where+ liftCompare = liftCompare2 compare+instance Ord2 p => Ord2 (Flip p) where+ liftCompare2 f g (Flip x) (Flip y) = liftCompare2 g f x y++instance (Read2 p, Read a) => Read1 (Flip p a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance Read2 p => Read2 (Flip p) where+ liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do+ ("Flip", s1) <- lex s0+ ("{", s2) <- lex s1+ ("runFlip", s3) <- lex s2+ (x, s4) <- liftReadsPrec2 rp2 rl2 rp1 rl1 0 s3+ ("}", s5) <- lex s4+ return (Flip x, s5)++instance (Show2 p, Show a) => Show1 (Flip p a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance Show2 p => Show2 (Flip p) where+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (Flip x) = showParen (p > 10) $+ showString "Flip {runFlip = "+ . liftShowsPrec2 sp2 sl2 sp1 sl1 0 x+ . showChar '}'+ instance Bifunctor p => Bifunctor (Flip p) where first f = Flip . second f . runFlip {-# INLINE first #-}@@ -87,6 +83,10 @@ bifoldMap f g = bifoldMap g f . runFlip {-# INLINE bifoldMap #-} +instance Bifoldable1 p => Bifoldable1 (Flip p) where+ bifoldMap1 f g = bifoldMap1 g f . runFlip+ {-# INLINE bifoldMap1 #-}+ instance Bifoldable p => Foldable (Flip p a) where foldMap f = bifoldMap f (const mempty) . runFlip {-# INLINE foldMap #-}@@ -101,3 +101,12 @@ instance BifunctorFunctor Flip where bifmap f (Flip p) = Flip (f p)++-- | @since 5.6.1+instance Assoc p => Assoc (Flip p) where+ assoc = Flip . first Flip . unassoc . second runFlip . runFlip+ unassoc = Flip . second Flip . assoc . first runFlip . runFlip++-- | @since 5.6.1+instance Swap p => Swap (Flip p) where+ swap = Flip . swap . runFlip
src/Data/Bifunctor/Functor.hs view
@@ -1,14 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif+{-# LANGUAGE TypeOperators #-} module Data.Bifunctor.Functor ( (:->)@@ -32,9 +25,7 @@ bibind f = bijoin . bifmap f bijoin :: t (t p) :-> t p bijoin = bibind id-#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bireturn, (bibind | bijoin) #-}-#endif biliftM :: BifunctorMonad t => (p :-> q) -> t p :-> t q biliftM f = bibind (bireturn . f)@@ -46,9 +37,7 @@ biextend f = bifmap f . biduplicate biduplicate :: t p :-> t (t p) biduplicate = biextend id-#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL biextract, (biextend | biduplicate) #-}-#endif biliftW :: BifunctorComonad t => (p :-> q) -> t p :-> t q biliftW f = biextend (f . biextract)
src/Data/Bifunctor/Join.hs view
@@ -1,23 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif- ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett@@ -32,44 +19,44 @@ ( Join(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Foldable1 (Foldable1(..))+import Data.Functor.Classes import GHC.Generics-#endif -- | Make a 'Functor' over both arguments of a 'Bifunctor'. newtype Join p a = Join { runJoin :: p a a }- deriving- (-#if __GLASGOW_HASKELL__ >= 702- Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable-#endif- )+ deriving Generic deriving instance Eq (p a a) => Eq (Join p a) deriving instance Ord (p a a) => Ord (Join p a) deriving instance Show (p a a) => Show (Join p a) deriving instance Read (p a a) => Read (Join p a) +instance Eq2 p => Eq1 (Join p) where+ liftEq f (Join x) (Join y) = liftEq2 f f x y++instance Ord2 p => Ord1 (Join p) where+ liftCompare f (Join x) (Join y) = liftCompare2 f f x y++instance Read2 p => Read1 (Join p) where+ liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do+ ("Join", s1) <- lex s0+ ("{", s2) <- lex s1+ ("runJoin", s3) <- lex s2+ (x, s4) <- liftReadsPrec2 rp1 rl1 rp1 rl1 0 s3+ ("}", s5) <- lex s4+ return (Join x, s5)++instance Show2 p => Show1 (Join p) where+ liftShowsPrec sp1 sl1 p (Join x) = showParen (p > 10) $+ showString "Join {runJoin = "+ . liftShowsPrec2 sp1 sl1 sp1 sl1 0 x+ . showChar '}'+ instance Bifunctor p => Functor (Join p) where fmap f (Join a) = Join (bimap f f a) {-# INLINE fmap #-}@@ -87,6 +74,10 @@ instance Bifoldable p => Foldable (Join p) where foldMap f (Join a) = bifoldMap f f a {-# INLINE foldMap #-}++instance Bifoldable1 p => Foldable1 (Join p) where+ foldMap1 f (Join a) = bifoldMap1 f f a+ {-# INLINE foldMap1 #-} instance Bitraversable p => Traversable (Join p) where traverse f (Join a) = fmap Join (bitraverse f f a)
src/Data/Bifunctor/Joker.hs view
@@ -1,21 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -33,65 +20,68 @@ ( Joker(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Foldable1 (Foldable1(..))+import Data.Functor.Classes import GHC.Generics-#endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Joker g a b = Joker { runJoker :: g b }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )+ deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data JokerMetaData-data JokerMetaCons-data JokerMetaSel+instance Eq1 g => Eq1 (Joker g a) where+ liftEq g = eqJoker (liftEq g)+instance Eq1 g => Eq2 (Joker g) where+ liftEq2 _ g = eqJoker (liftEq g) -instance Datatype JokerMetaData where- datatypeName _ = "Joker"- moduleName _ = "Data.Bifunctor.Joker"+instance Ord1 g => Ord1 (Joker g a) where+ liftCompare g = compareJoker (liftCompare g)+instance Ord1 g => Ord2 (Joker g) where+ liftCompare2 _ g = compareJoker (liftCompare g) -instance Constructor JokerMetaCons where- conName _ = "Joker"- conIsRecord _ = True+instance Read1 g => Read1 (Joker g a) where+ liftReadsPrec rp rl = readsPrecJoker (liftReadsPrec rp rl)+instance Read1 g => Read2 (Joker g) where+ liftReadsPrec2 _ _ rp2 rl2 = readsPrecJoker (liftReadsPrec rp2 rl2) -instance Selector JokerMetaSel where- selName _ = "runJoker"+instance Show1 g => Show1 (Joker g a) where+ liftShowsPrec sp sl = showsPrecJoker (liftShowsPrec sp sl)+instance Show1 g => Show2 (Joker g) where+ liftShowsPrec2 _ _ sp2 sl2 = showsPrecJoker (liftShowsPrec sp2 sl2) -instance Generic1 (Joker g a) where- type Rep1 (Joker g a) = D1 JokerMetaData (C1 JokerMetaCons- (S1 JokerMetaSel (Rec1 g)))- from1 = M1 . M1 . M1 . Rec1 . runJoker- to1 = Joker . unRec1 . unM1 . unM1 . unM1-#endif+eqJoker :: (g b1 -> g b2 -> Bool)+ -> Joker g a1 b1 -> Joker g a2 b2 -> Bool+eqJoker eqB (Joker x) (Joker y) = eqB x y +compareJoker :: (g b1 -> g b2 -> Ordering)+ -> Joker g a1 b1 -> Joker g a2 b2 -> Ordering+compareJoker compareB (Joker x) (Joker y) = compareB x y++readsPrecJoker :: (Int -> ReadS (g b))+ -> Int -> ReadS (Joker g a b)+readsPrecJoker rpB p =+ readParen (p > 10) $ \s0 -> do+ ("Joker", s1) <- lex s0+ ("{", s2) <- lex s1+ ("runJoker", s3) <- lex s2+ (x, s4) <- rpB 0 s3+ ("}", s5) <- lex s4+ return (Joker x, s5)++showsPrecJoker :: (Int -> g b -> ShowS)+ -> Int -> Joker g a b -> ShowS+showsPrecJoker spB p (Joker x) =+ showParen (p > 10) $+ showString "Joker {runJoker = "+ . spB 0 x+ . showChar '}'+ instance Functor g => Bifunctor (Joker g) where first _ = Joker . runJoker {-# INLINE first #-}@@ -115,9 +105,17 @@ bifoldMap _ g = foldMap g . runJoker {-# INLINE bifoldMap #-} +instance Foldable1 g => Bifoldable1 (Joker g) where+ bifoldMap1 _ g = foldMap1 g . runJoker+ {-# INLINE bifoldMap1 #-}+ instance Foldable g => Foldable (Joker g a) where foldMap g = foldMap g . runJoker {-# INLINE foldMap #-}++instance Foldable1 g => Foldable1 (Joker g a) where+ foldMap1 g = foldMap1 g . runJoker+ {-# INLINE foldMap1 #-} instance Traversable g => Bitraversable (Joker g) where bitraverse _ g = fmap Joker . traverse g . runJoker
src/Data/Bifunctor/Product.hs view
@@ -1,21 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -32,57 +24,54 @@ ( Product(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-+import qualified Control.Arrow as A+import Control.Category import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bifunctor.Functor+import Data.Bifunctor.Swap (Swap (..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Monoid hiding (Product)-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Functor.Classes+import qualified Data.Semigroup as S import GHC.Generics-#endif +import Prelude hiding ((.),id)+ -- | Form the product of two bifunctors data Product f g a b = Pair (f a b) (g a b)- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )+ deriving (Eq, Ord, Show, Read, Generic, Generic1)+deriving instance (Functor (f a), Functor (g a)) => Functor (Product f g a)+deriving instance (Foldable (f a), Foldable (g a)) => Foldable (Product f g a)+deriving instance (Traversable (f a), Traversable (g a)) => Traversable (Product f g a) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data ProductMetaData-data ProductMetaCons+instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Product f g a) where+ liftEq = liftEq2 (==)+instance (Eq2 f, Eq2 g) => Eq2 (Product f g) where+ liftEq2 f g (Pair x1 y1) (Pair x2 y2) =+ liftEq2 f g x1 x2 && liftEq2 f g y1 y2 -instance Datatype ProductMetaData where- datatypeName _ = "Product"- moduleName _ = "Data.Bifunctor.Product"+instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Product f g a) where+ liftCompare = liftCompare2 compare+instance (Ord2 f, Ord2 g) => Ord2 (Product f g) where+ liftCompare2 f g (Pair x1 y1) (Pair x2 y2) =+ liftCompare2 f g x1 x2 `mappend` liftCompare2 f g y1 y2 -instance Constructor ProductMetaCons where- conName _ = "Pair"+instance (Read2 f, Read2 g, Read a) => Read1 (Product f g a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Read2 f, Read2 g) => Read2 (Product f g) where+ liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $+ readsBinaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2)+ (liftReadsPrec2 rp1 rl1 rp2 rl2)+ "Pair" Pair -instance Generic1 (Product f g a) where- type Rep1 (Product f g a) = D1 ProductMetaData (C1 ProductMetaCons ((:*:)- (S1 NoSelector (Rec1 (f a)))- (S1 NoSelector (Rec1 (g a)))))- from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))- to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)-#endif+instance (Show2 f, Show2 g, Show a) => Show1 (Product f g a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance (Show2 f, Show2 g) => Show2 (Product f g) where+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (Pair x y) =+ showsBinaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2)+ (liftShowsPrec2 sp1 sl1 sp2 sl2)+ "Pair" p x y instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where first f (Pair x y) = Pair (first f x) (first f y)@@ -102,6 +91,10 @@ bifoldMap f g (Pair x y) = bifoldMap f g x `mappend` bifoldMap f g y {-# INLINE bifoldMap #-} +instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Product f g) where+ bifoldMap1 f g (Pair x y) = bifoldMap1 f g x S.<> bifoldMap1 f g y+ {-# INLINE bifoldMap1 #-}+ instance (Bitraversable f, Bitraversable g) => Bitraversable (Product f g) where bitraverse f g (Pair x y) = Pair <$> bitraverse f g x <*> bitraverse f g y {-# INLINE bitraverse #-}@@ -113,3 +106,33 @@ biextract (Pair _ q) = q biduplicate pq@(Pair p _) = Pair p pq biextend f pq@(Pair p _) = Pair p (f pq)++instance (Category p, Category q) => Category (Product p q) where+ id = Pair id id+ Pair x y . Pair x' y' = Pair (x . x') (y . y')++instance (A.Arrow p, A.Arrow q) => A.Arrow (Product p q) where+ arr f = Pair (A.arr f) (A.arr f)+ first (Pair x y) = Pair (A.first x) (A.first y)+ second (Pair x y) = Pair (A.second x) (A.second y)+ Pair x y *** Pair x' y' = Pair (x A.*** x') (y A.*** y')+ Pair x y &&& Pair x' y' = Pair (x A.&&& x') (y A.&&& y')++instance (A.ArrowChoice p, A.ArrowChoice q) => A.ArrowChoice (Product p q) where+ left (Pair x y) = Pair (A.left x) (A.left y)+ right (Pair x y) = Pair (A.right x) (A.right y)+ Pair x y +++ Pair x' y' = Pair (x A.+++ x') (y A.+++ y')+ Pair x y ||| Pair x' y' = Pair (x A.||| x') (y A.||| y')++instance (A.ArrowLoop p, A.ArrowLoop q) => A.ArrowLoop (Product p q) where+ loop (Pair x y) = Pair (A.loop x) (A.loop y)++instance (A.ArrowZero p, A.ArrowZero q) => A.ArrowZero (Product p q) where+ zeroArrow = Pair A.zeroArrow A.zeroArrow++instance (A.ArrowPlus p, A.ArrowPlus q) => A.ArrowPlus (Product p q) where+ Pair x y <+> Pair x' y' = Pair (x A.<+> x') (y A.<+> y')++-- | @since 5.6.1+instance (Swap p, Swap q) => Swap (Product p q) where+ swap (Pair p q) = Pair (swap p) (swap q)
src/Data/Bifunctor/Sum.hs view
@@ -1,73 +1,60 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} module Data.Bifunctor.Sum where import Data.Bifunctor import Data.Bifunctor.Functor+import Data.Bifunctor.Swap (Swap (..)) import Data.Bifoldable import Data.Bitraversable-#if __GLASGOW_HASKELL__ < 710-import Data.Functor-#endif-#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif-#if __GLASGOW_HASKELL__ >= 702+import Data.Functor.Classes import GHC.Generics-#endif data Sum p q a b = L2 (p a b) | R2 (q a b)- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data SumMetaData-data SumMetaConsL2-data SumMetaConsR2+ deriving (Eq, Ord, Show, Read, Generic, Generic1)+deriving instance (Functor (f a), Functor (g a)) => Functor (Sum f g a)+deriving instance (Foldable (f a), Foldable (g a)) => Foldable (Sum f g a)+deriving instance (Traversable (f a), Traversable (g a)) => Traversable (Sum f g a) -instance Datatype SumMetaData where- datatypeName _ = "Sum"- moduleName _ = "Data.Bifunctor.Sum"+instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Sum f g a) where+ liftEq = liftEq2 (==)+instance (Eq2 f, Eq2 g) => Eq2 (Sum f g) where+ liftEq2 f g (L2 x1) (L2 x2) = liftEq2 f g x1 x2+ liftEq2 _ _ (L2 _) (R2 _) = False+ liftEq2 _ _ (R2 _) (L2 _) = False+ liftEq2 f g (R2 y1) (R2 y2) = liftEq2 f g y1 y2 -instance Constructor SumMetaConsL2 where- conName _ = "L2"+instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Sum f g a) where+ liftCompare = liftCompare2 compare+instance (Ord2 f, Ord2 g) => Ord2 (Sum f g) where+ liftCompare2 f g (L2 x1) (L2 x2) = liftCompare2 f g x1 x2+ liftCompare2 _ _ (L2 _) (R2 _) = LT+ liftCompare2 _ _ (R2 _) (L2 _) = GT+ liftCompare2 f g (R2 y1) (R2 y2) = liftCompare2 f g y1 y2 -instance Constructor SumMetaConsR2 where- conName _ = "R2"+instance (Read2 f, Read2 g, Read a) => Read1 (Sum f g a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Read2 f, Read2 g) => Read2 (Sum f g) where+ liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $+ readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "L2" L2 `mappend`+ readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "R2" R2 -instance Generic1 (Sum p q a) where- type Rep1 (Sum p q a) = D1 SumMetaData ((:+:)- (C1 SumMetaConsL2 (S1 NoSelector (Rec1 (p a))))- (C1 SumMetaConsR2 (S1 NoSelector (Rec1 (q a)))))- from1 (L2 p) = M1 (L1 (M1 (M1 (Rec1 p))))- from1 (R2 q) = M1 (R1 (M1 (M1 (Rec1 q))))- to1 (M1 (L1 (M1 (M1 p)))) = L2 (unRec1 p)- to1 (M1 (R1 (M1 (M1 q)))) = R2 (unRec1 q)-#endif+instance (Show2 f, Show2 g, Show a) => Show1 (Sum f g a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance (Show2 f, Show2 g) => Show2 (Sum f g) where+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (L2 x) =+ showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "L2" p x+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (R2 y) =+ showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "R2" p y instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where bimap f g (L2 p) = L2 (bimap f g p)@@ -95,3 +82,8 @@ bijoin (R2 q) = q bibind _ (L2 p) = L2 p bibind f (R2 q) = f q++-- | @since 5.6.1+instance (Swap p, Swap q) => Swap (Sum p q) where+ swap (L2 p) = L2 (swap p)+ swap (R2 q) = R2 (swap q)
src/Data/Bifunctor/TH.hs view
@@ -1,1216 +1,1308 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE BangPatterns #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif--#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif--------------------------------------------------------------------------------- |--- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Functions to mechanically derive 'Bifunctor', 'Bifoldable',--- or 'Bitraversable' instances, or to splice their functions directly into--- source code. You need to enable the @TemplateHaskell@ language extension--- in order to use this module.-------------------------------------------------------------------------------module Data.Bifunctor.TH (- -- * @derive@- functions- -- $derive- -- * @make@- functions- -- $make- -- * 'Bifunctor'- deriveBifunctor- , makeBimap- -- * 'Bifoldable'- , deriveBifoldable- , makeBifold- , makeBifoldMap- , makeBifoldr- , makeBifoldl- -- * 'Bitraversable'- , deriveBitraversable- , makeBitraverse- , makeBisequenceA- , makeBimapM- , makeBisequence- ) 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.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Syntax------------------------------------------------------------------------------------ User-facing API----------------------------------------------------------------------------------{- $derive--'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically-generate their respective class instances for a given data type, newtype, or data-family instance that has at least two type variable. Examples:--@-{-# LANGUAGE TemplateHaskell #-}-import Data.Bifunctor.TH--data Pair a b = Pair a b-$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ...--data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b)-$('deriveBifoldable' ''WrapLeftPair)--- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ...-@--If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),-the @derive@ functions can be used data family instances (which requires the-@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance-constructor (NOT a data family name!) to a @derive@ function. Note that the-generated code may require the @-XFlexibleInstances@ extension. Example:--@-{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}-import Data.Bifunctor.TH--class AssocClass a b c where- data AssocData a b c-instance AssocClass Int b c where- data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c-$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ...--- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2)-@--Note that there are some limitations:--* The 'Name' argument to a @derive@ function must not be a type synonym.--* With a @derive@ function, the last two type variables must both be of kind @*@.- Other type variables of kind @* -> *@ are assumed to require a 'Functor',- 'Foldable', or 'Traversable' constraint (depending on which @derive@ function is- used), and other type variables of kind @* -> * -> *@ are assumed to require an- 'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type- doesn't meet these assumptions, use a @make@ function.--* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@- extensions, a constraint cannot mention either of the last two type variables. For- example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot- have a derived 'Bifunctor' instance.--* If either of the last two type variables is used within a constructor argument's- type, it must only be used in the last two type arguments. For example,- @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance,- but @data Illegal a b = Illegal (a, b, a, b)@ cannot.--* Data family instances must be able to eta-reduce the last two type variables. In other- words, if you have a instance of the form:-- @- data family Family a1 ... an t1 t2- data instance Family e1 ... e2 v1 v2 = ...- @-- Then the following conditions must hold:-- 1. @v1@ and @v2@ must be distinct type variables.- 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.---}--{- $make--There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type-or data family instance without having to make the type an instance of 'Bifunctor'. For-these cases, this module provides several functions (all prefixed with @make@-) that-splice the appropriate lambda expression into your source code.--This is particularly useful for creating instances for sophisticated data types. For-example, 'deriveBifunctor' cannot infer the correct type context for-@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind-@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for-@HigherKinded@ without too much trouble using 'makeBimap':--@-{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}-import Data.Bifunctor-import Data.Bifunctor.TH--newtype HigherKinded f a b c = HigherKinded (f a b c)--instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where- bimap = $(makeBimap ''HigherKinded)-@---}---- | Generates a 'Bifunctor' instance declaration for the given data type or data--- family instance.-deriveBifunctor :: Name -> Q [Dec]-deriveBifunctor = deriveBiClass Bifunctor---- | Generates a lambda expression which behaves like 'bimap' (without requiring a--- 'Bifunctor' instance).-makeBimap :: Name -> Q Exp-makeBimap = makeBiFun Bimap---- | Generates a 'Bifoldable' instance declaration for the given data type or data--- family instance.-deriveBifoldable :: Name -> Q [Dec]-deriveBifoldable = deriveBiClass Bifoldable---- | 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- ]---- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a--- 'Bifoldable' instance).-makeBifoldMap :: Name -> Q Exp-makeBifoldMap = makeBiFun BifoldMap---- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a--- 'Bifoldable' instance).-makeBifoldr :: Name -> Q Exp-makeBifoldr = makeBiFun Bifoldr---- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a--- 'Bifoldable' instance).-makeBifoldl :: Name -> Q Exp-makeBifoldl name = do- f <- newName "f"- g <- newName "g"- z <- newName "z"- t <- newName "t"- lamE [varP f, varP g, varP z, varP t] $- appsE [ varE appEndoValName- , appsE [ varE getDualValName- , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t]- ]- , varE z- ]- where- foldFun :: Name -> Q Exp- foldFun n = infixApp (conE dualDataName)- (varE composeValName)- (infixApp (conE endoDataName)- (varE composeValName)- (varE flipValName `appE` varE n)- )---- | Generates a 'Bitraversable' instance declaration for the given data type or data--- family instance.-deriveBitraversable :: Name -> Q [Dec]-deriveBitraversable = deriveBiClass Bitraversable---- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a--- 'Bitraversable' instance).-makeBitraverse :: Name -> Q Exp-makeBitraverse = makeBiFun Bitraverse---- | 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- ]---- | Generates a lambda expression which behaves like 'bimapM' (without requiring a--- 'Bitraversable' instance).-makeBimapM :: Name -> Q Exp-makeBimapM 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]- 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).-makeBisequence :: Name -> Q Exp-makeBisequence name = appsE [ makeBimapM 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)---- | 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)- []- ]---- | 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---- | 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- 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- 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)- ] ++ map varE argNames---- | 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---- | 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)- []- where- mappedArgs :: Q [Either Exp Exp]- mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args---- | Generates a lambda expression for a single argument of a constructor.--- The returned value is 'Right' if its type mentions one of the last two type--- parameters. Otherwise, it is 'Left'.-makeBiFunForArg :: BiFun- -> TyVarMap- -> Name- -> Type- -> Name- -> Q (Either Exp Exp)-makeBiFunForArg biFun tvMap conName ty tyExpName =- makeBiFunForType biFun tvMap conName True ty `appEitherE` varE tyExpName---- | Generates a lambda expression for a specific type. The returned value is--- 'Right' if its type mentions one of the last two type parameters. Otherwise,--- it is 'Left'.-makeBiFunForType :: BiFun- -> TyVarMap- -> Name- -> Bool- -> Type- -> Q (Either Exp Exp)-makeBiFunForType biFun tvMap conName covariant (VarT tyName) =- case Map.lookup tyName tvMap of- Just mapName -> fmap Right . varE $- if covariant- then mapName- else contravarianceError conName- Nothing -> fmap Left $ biFunTriv biFun-makeBiFunForType biFun tvMap conName covariant (SigT ty _) =- makeBiFunForType biFun tvMap conName covariant ty-makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) =- makeBiFunForType biFun tvMap conName covariant ty-makeBiFunForType biFun tvMap conName covariant ty =- let tyCon :: Type- tyArgs :: [Type]- tyCon:tyArgs = unapplyTy ty-- numLastArgs :: Int- numLastArgs = min 2 $ length tyArgs-- 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-- 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------------------------------------------------------------------------------------ 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.-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- -> 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- -- 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-- let remainingLength :: Int- remainingLength = length varTysOrig - 2-- droppedTysExp :: [Type]- droppedTysExp = drop remainingLength varTysExp-- droppedStarKindStati :: [StarKindStatus]- droppedStarKindStati = map canRealizeKindStar droppedTysExp-- -- Check there are enough types to drop and that all of them are either of- -- kind * or kind k (for some kind variable k). If not, throw an error.- when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $- derivingKindError biClass tyConName-- let droppedKindVarNames :: [Name]- droppedKindVarNames = catKindVarNames droppedStarKindStati-- -- Substitute kind * for any dropped kind variables- varTysExpSubst :: [Type]- varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp-- remainingTysExpSubst, droppedTysExpSubst :: [Type]- (remainingTysExpSubst, droppedTysExpSubst) =- splitAt remainingLength varTysExpSubst-- -- All of the type variables mentioned in the dropped types- -- (post-synonym expansion)- droppedTyVarNames :: [Name]- droppedTyVarNames = concatMap tyVarNamesOfType 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.- unless (all hasKindStar droppedTysExpSubst) $- derivingKindError biClass tyConName-- let preds :: [Maybe Pred]- kvNames :: [[Name]]- kvNames' :: [Name]- -- Derive instance constraints (and any kind variables which are specialized- -- to * in those constraints)- (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst- kvNames' = concat kvNames-- -- Substitute the kind variables specialized in the constraints with *- remainingTysExpSubst' :: [Type]- remainingTysExpSubst' =- map (substNamesWithKindStar kvNames') remainingTysExpSubst-- -- We now substitute all of the specialized-to-* kind variable names with- -- *, but in the original types, not the synonym-expanded types. The reason- -- we do this is a superficial one: we want the derived instance to resemble- -- the datatype written in source code as closely as possible. For example,- -- for the following data family instance:- --- -- data family Fam a- -- newtype instance Fam String = Fam String- --- -- We'd want to generate the instance:- --- -- instance C (Fam String)- --- -- Not:- --- -- instance C (Fam [Char])- remainingTysOrigSubst :: [Type]- remainingTysOrigSubst =- map (substNamesWithKindStar (union droppedKindVarNames kvNames'))- $ take remainingLength varTysOrig-- remainingTysOrigSubst' :: [Type]- -- See Note [Kind signatures in derived instances] for an explanation- -- of the isDataFamily check.- remainingTysOrigSubst' =- if isDataFamily- then remainingTysOrigSubst- else map unSigT remainingTysOrigSubst-- instanceCxt :: Cxt- instanceCxt = catMaybes preds-- instanceType :: Type- instanceType = AppT (ConT $ biClassName biClass)- $ applyTyCon tyConName remainingTysOrigSubst'-- -- If the datatype context mentions any of the dropped type variables,- -- we can't derive an instance, so throw an error.- when (any (`predMentionsName` droppedTyVarNames) dataCxt) $- datatypeContextError tyConName instanceType- -- Also ensure the dropped types can be safely eta-reduced. Otherwise,- -- throw an error.- unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $- etaReductionError instanceType- return (instanceCxt, instanceType)---- | Attempt to derive a constraint on a Type. If successful, return--- Just the constraint and any kind variable names constrained to *.--- Otherwise, return Nothing and the empty list.------ See Note [Type inference in derived instances] for the heuristics used to--- come up with constraints.-deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name])-deriveConstraint biClass t- | not (isTyVar t) = (Nothing, [])- | otherwise = case hasKindVarChain 1 t of- Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns)- _ -> case hasKindVarChain 2 t of- Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns)- _ -> (Nothing, [])- where- tName :: Name- 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is possible to put explicit kind signatures into the derived instances, e.g.,-- instance C a => C (Data (f :: * -> *)) where ...--But it is preferable to avoid this if possible. If we come up with an incorrect-kind signature (which is entirely possible, since our type inferencer is pretty-unsophisticated - see Note [Type inference in derived instances]), then GHC will-flat-out reject the instance, which is quite unfortunate.--Plain old datatypes have the advantage that you can avoid using any kind signatures-at all in their instances. This is because a datatype declaration uses all type-variables, so the types that we use in a derived instance uniquely determine their-kinds. As long as we plug in the right types, the kind inferencer can do the rest-of the work. For this reason, we use unSigT to remove all kind signatures before-splicing in the instance context and head.--Data family instances are trickier, since a data family can have two instances that-are distinguished by kind alone, e.g.,-- data family Fam (a :: k)- data instance Fam (a :: * -> *)- data instance Fam (a :: *)--If we dropped the kind signatures for C (Fam a), then GHC will have no way of-knowing which instance we are talking about. To avoid this scenario, we always-include explicit kind signatures in data family instances. There is a chance that-the inferred kind signatures will be incorrect, but if so, we can always fall back-on the make- functions.--Note [Type inference in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Type inference is can be tricky to get right, and we want to avoid recreating the-entirety of GHC's type inferencer in Template Haskell. For this reason, we will-probably never come up with derived instance contexts that are as accurate as-GHC's. But that doesn't mean we can't do anything! There are a couple of simple-things we can do to make instance contexts that work for 80% of use cases:--1. If one of the last type parameters is polykinded, then its kind will be- specialized to * in the derived instance. We note what kind variable the type- parameter had and substitute it with * in the other types as well. For example,- imagine you had-- data Data (a :: k) (b :: k) (c :: k)-- Then you'd want to derived instance to be:-- instance C (Data (a :: *))-- Not:-- instance C (Data (a :: k))--2. We naïvely come up with instance constraints using the following criteria:-- (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind- variables), then generate a Functor n constraint, and if k1/k2 are kind- variables, then substitute k1/k2 with * elsewhere in the types. We must- consider the case where they are kind variables because you might have a- scenario like this:-- newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)- = Compose (f (g a b))-- Which would have a derived Bifunctor instance of:-- instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ...- (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are- * or kind variables), then generate a Bifunctor n constraint and perform- 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When deriving Bifoldable, there is a tricky corner case to consider:-- data Both a b where- BothCon :: x -> x -> Both x x--Which fold functions should be applied to which arguments of BothCon? We have a-choice, since both the function of type (a -> m) and of type (b -> m) can be-applied to either argument. In such a scenario, the second fold function takes-precedence over the first fold function, so the derived Bifoldable instance would be:-- instance Bifoldable Both where- bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2--This is not an arbitrary choice, as this definition ensures that-bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both.--}------------------------------------------------------------------------------------ Error messages------------------------------------------------------------------------------------ | 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- . showString "Cannot derive well-kinded instance of form ‘"- . showString className- . showChar ' '- . showParen True- ( showString (nameBase tyConName)- . showString " ..."- )- . showString "‘\n\tClass "- . showString className- . showString " expects an argument of kind * -> * -> *"- $ ""- where- className :: String- className = nameBase $ biClassName biClass---- | One of the last two type variables appeard in a contravariant position--- when deriving Bifoldable or Bitraversable.-contravarianceError :: Name -> a-contravarianceError conName = error- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not use the last type variable(s) in a function argument"- $ ""---- | A constructor has a function argument in a derived Bifoldable or Bitraversable--- instance.-noFunctionsError :: Name -> a-noFunctionsError conName = error- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not contain function types"- $ ""---- | The data type has a DatatypeContext which mentions one of the eta-reduced--- type variables.-datatypeContextError :: Name -> Type -> a-datatypeContextError dataName instanceType = error- . showString "Can't make a derived instance of ‘"- . showString (pprint instanceType)- . showString "‘:\n\tData type ‘"- . showString (nameBase dataName)- . showString "‘ must not have a class context involving the last type argument(s)"- $ ""---- | The data type has an existential constraint which mentions one of the--- eta-reduced type variables.-existentialContextError :: Name -> a-existentialContextError conName = error- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must be truly polymorphic in the last argument(s) of the data type"- $ ""---- | 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- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must only use its last two type variable(s) within"- . showString " the last two argument(s) of a data type"- $ ""---- | 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 $- "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------------------------------------------------------------------------------------ | A representation of which class is being derived.-data BiClass = Bifunctor | Bifoldable | Bitraversable---- | A representation of which function is being generated.-data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse- deriving Eq--biFunConstName :: BiFun -> Name-biFunConstName Bimap = bimapConstValName-biFunConstName Bifoldr = bifoldrConstValName-biFunConstName BifoldMap = bifoldMapConstValName-biFunConstName Bitraverse = bitraverseConstValName--biClassName :: BiClass -> Name-biClassName Bifunctor = bifunctorTypeName-biClassName Bifoldable = bifoldableTypeName-biClassName Bitraversable = bitraversableTypeName--biFunName :: BiFun -> Name-biFunName Bimap = bimapValName-biFunName Bifoldr = bifoldrValName-biFunName BifoldMap = bifoldMapValName-biFunName Bitraverse = bitraverseValName--biClassToFuns :: BiClass -> [BiFun]-biClassToFuns Bifunctor = [Bimap]-biClassToFuns Bifoldable = [Bifoldr, BifoldMap]-biClassToFuns Bitraversable = [Bitraverse]--biFunToClass :: BiFun -> BiClass-biFunToClass Bimap = Bifunctor-biFunToClass Bifoldr = Bifoldable-biFunToClass BifoldMap = Bifoldable-biFunToClass Bitraverse = Bitraversable--biClassConstraint :: BiClass -> Int -> Maybe Name-biClassConstraint Bifunctor 1 = Just functorTypeName-biClassConstraint Bifoldable 1 = Just foldableTypeName-biClassConstraint Bitraversable 1 = Just traversableTypeName-biClassConstraint biClass 2 = Just $ biClassName biClass-biClassConstraint _ _ = Nothing--biFunArity :: BiFun -> Int -> Maybe Name-biFunArity Bimap 1 = Just fmapValName-biFunArity Bifoldr 1 = Just foldrValName-biFunArity BifoldMap 1 = Just foldMapValName-biFunArity Bitraverse 1 = Just traverseValName-biFunArity biFun 2 = Just $ biFunName biFun-biFunArity _ _ = Nothing--allowFunTys :: BiClass -> Bool-allowFunTys Bifunctor = True-allowFunTys _ = False--allowExQuant :: BiClass -> Bool-allowExQuant Bifoldable = True-allowExQuant _ = False---- See Trac #7436 for why explicit lambdas are used-biFunTriv :: BiFun -> Q Exp-biFunTriv Bimap = do- x <- newName "x"- lamE [varP x] $ varE x--- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem--- useless, but they do serve a purpose.--- See Note [biFunTriv for Bifoldable and Bitraversable]-biFunTriv Bifoldr = do- z <- newName "z"- lamE [wildP, varP z] $ varE z-biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName-biFunTriv Bitraverse = varE pureValName--biFunApp :: BiFun -> Q Exp -> Q Exp-biFunApp Bifoldr e = do- x <- newName "x"- z <- newName "z"- lamE [varP x, varP z] $ appsE [e, varE z, varE x]-biFunApp _ e = e--biFunCombine :: BiFun- -> Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-biFunCombine Bimap = bimapCombine-biFunCombine Bifoldr = bifoldrCombine-biFunCombine BifoldMap = bifoldMapCombine-biFunCombine Bitraverse = bitraverseCombine--bimapCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bimapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither)---- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since--- they filter out subexpressions whose types do not mention one of the last two--- type parameters. See--- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable--- for further discussion.--bifoldrCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bifoldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights)--bifoldMapCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bifoldMapCombine _ _ _ = fmap (go . rights)- where- go :: [Exp] -> Exp- go [] = VarE memptyValName- go es = foldr1 (AppE . AppE (VarE mappendValName)) es--bitraverseCombine :: Name- -> Name- -> [Name]- -> Q [Either Exp Exp]- -> Q Exp-bitraverseCombine conName _ args essQ = do- ess <- essQ-- let argTysTyVarInfo :: [Bool]- argTysTyVarInfo = map isRight ess-- 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--{--Note [biFunTriv 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-bitraverse at all, but in fact we do need to. Imagine the following data type:-- data T a b = MkT a (T Int b)--In a derived Bifoldable T instance, you would generate the following bifoldMap-definition:-- 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-call to bifoldMap, since that is how the algorithm handles polymorphic recursion.--}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Unsafe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Functions to mechanically derive 'Bifunctor', 'Bifoldable',+-- or 'Bitraversable' instances, or to splice their functions directly into+-- source code. You need to enable the @TemplateHaskell@ language extension+-- in order to use this module.+----------------------------------------------------------------------------++module Data.Bifunctor.TH (+ -- * @derive@- functions+ -- $derive+ -- * @make@- functions+ -- $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)++import Data.Bifunctor.TH.Internal+import qualified Data.List as List+import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size)+import Data.Maybe++import Language.Haskell.TH.Datatype as Datatype+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- 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.+ } 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+generate their respective class instances for a given data type, newtype, or data+family instance that has at least two type variable. Examples:++@+{-# LANGUAGE TemplateHaskell #-}+import Data.Bifunctor.TH++data Pair a b = Pair a b+$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ...++data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b)+$('deriveBifoldable' ''WrapLeftPair)+-- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ...+@++If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),+the @derive@ functions can be used data family instances (which requires the+@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance+constructor (NOT a data family name!) to a @derive@ function. Note that the+generated code may require the @-XFlexibleInstances@ extension. Example:++@+{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}+import Data.Bifunctor.TH++class AssocClass a b c where+ data AssocData a b c+instance AssocClass Int b c where+ data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c+$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ...+-- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2)+@++Note that there are some limitations:++* The 'Name' argument to a @derive@ function must not be a type synonym.++* With a @derive@ function, the last two type variables must both be of kind @*@.+ Other type variables of kind @* -> *@ are assumed to require a 'Functor',+ 'Foldable', or 'Traversable' constraint (depending on which @derive@ function is+ used), and other type variables of kind @* -> * -> *@ are assumed to require an+ 'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type+ doesn't meet these assumptions, use a @make@ function.++* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@+ extensions, a constraint cannot mention either of the last two type variables. For+ example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot+ have a derived 'Bifunctor' instance.++* If either of the last two type variables is used within a constructor argument's+ type, it must only be used in the last two type arguments. For example,+ @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance,+ but @data Illegal a b = Illegal (a, b, a, b)@ cannot.++* Data family instances must be able to eta-reduce the last two type variables. In other+ words, if you have a instance of the form:++ @+ data family Family a1 ... an t1 t2+ data instance Family e1 ... e2 v1 v2 = ...+ @++ Then the following conditions must hold:++ 1. @v1@ and @v2@ must be distinct type variables.+ 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.++-}++{- $make++There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type+or data family instance without having to make the type an instance of 'Bifunctor'. For+these cases, this module provides several functions (all prefixed with @make@-) that+splice the appropriate lambda expression into your source code.++This is particularly useful for creating instances for sophisticated data types. For+example, 'deriveBifunctor' cannot infer the correct type context for+@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind+@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for+@HigherKinded@ without too much trouble using 'makeBimap':++@+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}+import Data.Bifunctor+import Data.Bifunctor.TH++newtype HigherKinded f a b c = HigherKinded (f a b c)++instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where+ bimap = $(makeBimap ''HigherKinded)+@++-}++-- | Generates a 'Bifunctor' instance declaration for the given data type or data+-- family instance.+deriveBifunctor :: Name -> Q [Dec]+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 = 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 = 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+-- 'Bifoldable' instance).+makeBifold :: Name -> Q Exp+makeBifold = makeBifoldOptions defaultOptions++-- | 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 = 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 = 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 = 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"+ t <- newName "t"+ lamE [varP f, varP g, varP z, varP t] $+ appsE [ varE appEndoValName+ , appsE [ varE getDualValName+ , appsE [ makeBifoldMapOptions opts name+ , foldFun f+ , foldFun g+ , varE t]+ ]+ , varE z+ ]+ where+ foldFun :: Name -> Q Exp+ foldFun n = infixApp (conE dualDataName)+ (varE composeValName)+ (infixApp (conE endoDataName)+ (varE composeValName)+ (varE flipValName `appE` varE n)+ )++-- | Generates a 'Bitraversable' instance declaration for the given data type or data+-- family instance.+deriveBitraversable :: Name -> Q [Dec]+deriveBitraversable = deriveBitraversableOptions defaultOptions++-- | 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 = 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).+makeBisequenceA :: Name -> Q Exp+makeBisequenceA = makeBisequenceAOptions defaultOptions++-- | 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 = 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 [ 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).+makeBisequence :: Name -> Q Exp+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 -> Options -> Name -> Q [Dec]+deriveBiClass biClass opts name = do+ info <- reifyDatatype name+ case info of+ DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeInstTypes = instTys+ , datatypeVariant = variant+ , datatypeCons = cons+ } -> do+ (instanceCxt, instanceType)+ <- buildTypeInstance biClass parentName ctxt instTys variant+ (:[]) `fmap` instanceD (return instanceCxt)+ (return instanceType)+ (biFunDecs biClass opts parentName instTys 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 -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]+biFunDecs biClass opts parentName instTys cons =+ map makeFunD $ biClassToFuns biClass+ where+ makeFunD :: BiFun -> Q Dec+ makeFunD biFun =+ funD (biFunName biFun)+ [ clause []+ (normalB $ makeBiFunForCons biFun opts parentName instTys cons)+ []+ ]++-- | Generates a lambda expression which behaves like the BiFun argument.+makeBiFun :: BiFun -> Options -> Name -> Q Exp+makeBiFun biFun opts name = do+ info <- reifyDatatype name+ case info of+ DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeInstTypes = instTys+ , 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 instTys variant+ >> makeBiFunForCons biFun opts parentName instTys cons++-- | Generates a lambda expression for the given constructors.+-- All constructors must be from the same type.+makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp+makeBiFunForCons biFun opts _parentName instTys cons = do+ 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)+ . appsE+ $ [ varE $ biFunConstName biFun+ , makeFun z value tvMap+ ] ++ map varE argNames+ where+ makeFun :: Name -> Name -> TyVarMap -> Q Exp+ makeFun z value tvMap = do+ roles <- reifyRoles _parentName+ case () of+ _ | Just (rs, PhantomR) <- unsnoc roles+ , Just (_, PhantomR) <- unsnoc rs+ -> biFunPhantom z value++ | null cons && emptyCaseBehavior opts+ -> biFunEmptyCase biFun z value++ | null cons+ -> biFunNoCons biFun z value++ | otherwise+ -> caseE (varE value)+ (map (makeBiFunForCon biFun z tvMap) cons)++ 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++-- | Generates a match for a single constructor.+makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match+makeBiFunForCon biFun z tvMap+ 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+ -- 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+ }++ 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+ }++ 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) = List.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+-------------------------------------------------------------------------------++-- 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+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> DatatypeVariant+ -- ^ Are we dealing with a data family instance or not+ -> Q (Cxt, Type)+buildTypeInstance biClass tyConName dataCxt instTysOrig 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 resolveTypeSynonyms instTysOrig++ let remainingLength :: Int+ remainingLength = length instTysOrig - 2++ droppedTysExp :: [Type]+ droppedTysExp = drop remainingLength varTysExp++ droppedStarKindStati :: [StarKindStatus]+ droppedStarKindStati = map canRealizeKindStar droppedTysExp++ -- Check there are enough types to drop and that all of them are either of+ -- kind * or kind k (for some kind variable k). If not, throw an error.+ when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $+ derivingKindError biClass tyConName++ let droppedKindVarNames :: [Name]+ droppedKindVarNames = catKindVarNames droppedStarKindStati++ -- Substitute kind * for any dropped kind variables+ varTysExpSubst :: [Type]+ varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp++ remainingTysExpSubst, droppedTysExpSubst :: [Type]+ (remainingTysExpSubst, droppedTysExpSubst) =+ splitAt remainingLength varTysExpSubst++ -- All of the type variables mentioned in the dropped types+ -- (post-synonym expansion)+ droppedTyVarNames :: [Name]+ 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.+ unless (all hasKindStar droppedTysExpSubst) $+ derivingKindError biClass tyConName++ let preds :: [Maybe Pred]+ kvNames :: [[Name]]+ kvNames' :: [Name]+ -- Derive instance constraints (and any kind variables which are specialized+ -- to * in those constraints)+ (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst+ kvNames' = concat kvNames++ -- Substitute the kind variables specialized in the constraints with *+ remainingTysExpSubst' :: [Type]+ remainingTysExpSubst' =+ map (substNamesWithKindStar kvNames') remainingTysExpSubst++ -- We now substitute all of the specialized-to-* kind variable names with+ -- *, but in the original types, not the synonym-expanded types. The reason+ -- we do this is a superficial one: we want the derived instance to resemble+ -- the datatype written in source code as closely as possible. For example,+ -- for the following data family instance:+ --+ -- data family Fam a+ -- newtype instance Fam String = Fam String+ --+ -- We'd want to generate the instance:+ --+ -- instance C (Fam String)+ --+ -- Not:+ --+ -- instance C (Fam [Char])+ remainingTysOrigSubst :: [Type]+ remainingTysOrigSubst =+ map (substNamesWithKindStar (List.union droppedKindVarNames kvNames'))+ $ take remainingLength instTysOrig++ isDataFamily <-+ case variant of+ Datatype -> return False+ Newtype -> return False+ DataInstance -> return True+ NewtypeInstance -> return True+#if MIN_VERSION_th_abstraction(0,5,0)+ Datatype.TypeData -> typeDataError tyConName+#endif++ let remainingTysOrigSubst' :: [Type]+ -- See Note [Kind signatures in derived instances] for an explanation+ -- of the isDataFamily check.+ remainingTysOrigSubst' =+ if isDataFamily+ then remainingTysOrigSubst+ else map unSigT remainingTysOrigSubst++ instanceCxt :: Cxt+ instanceCxt = catMaybes preds++ instanceType :: Type+ instanceType = AppT (ConT $ biClassName biClass)+ $ applyTyCon tyConName remainingTysOrigSubst'++ -- If the datatype context mentions any of the dropped type variables,+ -- we can't derive an instance, so throw an error.+ when (any (`predMentionsName` droppedTyVarNames) dataCxt) $+ datatypeContextError tyConName instanceType+ -- Also ensure the dropped types can be safely eta-reduced. Otherwise,+ -- throw an error.+ unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $+ etaReductionError instanceType+ return (instanceCxt, instanceType)++-- | Attempt to derive a constraint on a Type. If successful, return+-- Just the constraint and any kind variable names constrained to *.+-- Otherwise, return Nothing and the empty list.+--+-- See Note [Type inference in derived instances] for the heuristics used to+-- come up with constraints.+deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name])+deriveConstraint biClass t+ | not (isTyVar t) = (Nothing, [])+ | otherwise = case hasKindVarChain 1 t of+ Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns)+ _ -> case hasKindVarChain 2 t of+ Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns)+ _ -> (Nothing, [])+ where+ tName :: Name+ tName = varTToName t++{-+Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is possible to put explicit kind signatures into the derived instances, e.g.,++ instance C a => C (Data (f :: * -> *)) where ...++But it is preferable to avoid this if possible. If we come up with an incorrect+kind signature (which is entirely possible, since our type inferencer is pretty+unsophisticated - see Note [Type inference in derived instances]), then GHC will+flat-out reject the instance, which is quite unfortunate.++Plain old datatypes have the advantage that you can avoid using any kind signatures+at all in their instances. This is because a datatype declaration uses all type+variables, so the types that we use in a derived instance uniquely determine their+kinds. As long as we plug in the right types, the kind inferencer can do the rest+of the work. For this reason, we use unSigT to remove all kind signatures before+splicing in the instance context and head.++Data family instances are trickier, since a data family can have two instances that+are distinguished by kind alone, e.g.,++ data family Fam (a :: k)+ data instance Fam (a :: * -> *)+ data instance Fam (a :: *)++If we dropped the kind signatures for C (Fam a), then GHC will have no way of+knowing which instance we are talking about. To avoid this scenario, we always+include explicit kind signatures in data family instances. There is a chance that+the inferred kind signatures will be incorrect, but if so, we can always fall back+on the make- functions.++Note [Type inference in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Type inference is can be tricky to get right, and we want to avoid recreating the+entirety of GHC's type inferencer in Template Haskell. For this reason, we will+probably never come up with derived instance contexts that are as accurate as+GHC's. But that doesn't mean we can't do anything! There are a couple of simple+things we can do to make instance contexts that work for 80% of use cases:++1. If one of the last type parameters is polykinded, then its kind will be+ specialized to * in the derived instance. We note what kind variable the type+ parameter had and substitute it with * in the other types as well. For example,+ imagine you had++ data Data (a :: k) (b :: k) (c :: k)++ Then you'd want to derived instance to be:++ instance C (Data (a :: *))++ Not:++ instance C (Data (a :: k))++2. We naïvely come up with instance constraints using the following criteria:++ (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind+ variables), then generate a Functor n constraint, and if k1/k2 are kind+ variables, then substitute k1/k2 with * elsewhere in the types. We must+ consider the case where they are kind variables because you might have a+ scenario like this:++ newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)+ = Compose (f (g a b))++ Which would have a derived Bifunctor instance of:++ instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ...+ (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are+ * or kind variables), then generate a Bifunctor n constraint and perform+ kind substitution as in the other case.+-}++{-+Note [Matching functions with GADT type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When deriving Bifoldable, there is a tricky corner case to consider:++ data Both a b where+ BothCon :: x -> x -> Both x x++Which fold functions should be applied to which arguments of BothCon? We have a+choice, since both the function of type (a -> m) and of type (b -> m) can be+applied to either argument. In such a scenario, the second fold function takes+precedence over the first fold function, so the derived Bifoldable instance would be:++ instance Bifoldable Both where+ bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2++This is not an arbitrary choice, as this definition ensures that+bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both.+-}++-------------------------------------------------------------------------------+-- Error messages+-------------------------------------------------------------------------------++-- | 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 -> Q a+derivingKindError biClass tyConName = fail+ . showString "Cannot derive well-kinded instance of form ‘"+ . showString className+ . showChar ' '+ . showParen True+ ( showString (nameBase tyConName)+ . showString " ..."+ )+ . showString "‘\n\tClass "+ . showString className+ . showString " expects an argument of kind * -> * -> *"+ $ ""+ where+ className :: String+ className = nameBase $ biClassName biClass++-- | One of the last two type variables appeared in a contravariant position+-- when deriving Bifoldable or Bitraversable.+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"+ $ ""++-- | A constructor has a function argument in a derived Bifoldable or Bitraversable+-- instance.+noFunctionsError :: Name -> Q a+noFunctionsError conName = fail+ . showString "Constructor ‘"+ . showString (nameBase conName)+ . showString "‘ must not contain function types"+ $ ""++-- | The data type has a DatatypeContext which mentions one of the eta-reduced+-- type variables.+datatypeContextError :: Name -> Type -> Q a+datatypeContextError dataName instanceType = fail+ . showString "Can't make a derived instance of ‘"+ . showString (pprint instanceType)+ . showString "‘:\n\tData type ‘"+ . showString (nameBase dataName)+ . showString "‘ must not have a class context involving the last type argument(s)"+ $ ""++-- | The data type has an existential constraint which mentions one of the+-- eta-reduced type variables.+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"+ $ ""++-- | 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 -> Q a+outOfPlaceTyVarError conName = fail+ . showString "Constructor ‘"+ . showString (nameBase conName)+ . showString "‘ must only use its last two type variable(s) within"+ . showString " the last two argument(s) of a data type"+ $ ""++-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $+ "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+ ++ pprint instanceType++typeDataError :: Name -> Q a+typeDataError dataName = fail+ . showString "Cannot derive instance for ‘"+ . showString (nameBase dataName)+ . showString "‘, which is a ‘type data‘ declaration"+ $ ""++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- | A representation of which class is being derived.+data BiClass = Bifunctor | Bifoldable | Bitraversable++-- | A representation of which function is being generated.+data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse+ deriving Eq++biFunConstName :: BiFun -> Name+biFunConstName Bimap = bimapConstValName+biFunConstName Bifoldr = bifoldrConstValName+biFunConstName BifoldMap = bifoldMapConstValName+biFunConstName Bitraverse = bitraverseConstValName++biClassName :: BiClass -> Name+biClassName Bifunctor = bifunctorTypeName+biClassName Bifoldable = bifoldableTypeName+biClassName Bitraversable = bitraversableTypeName++biFunName :: BiFun -> Name+biFunName Bimap = bimapValName+biFunName Bifoldr = bifoldrValName+biFunName BifoldMap = bifoldMapValName+biFunName Bitraverse = bitraverseValName++biClassToFuns :: BiClass -> [BiFun]+biClassToFuns Bifunctor = [Bimap]+biClassToFuns Bifoldable = [Bifoldr, BifoldMap]+biClassToFuns Bitraversable = [Bitraverse]++biFunToClass :: BiFun -> BiClass+biFunToClass Bimap = Bifunctor+biFunToClass Bifoldr = Bifoldable+biFunToClass BifoldMap = Bifoldable+biFunToClass Bitraverse = Bitraversable++biClassConstraint :: BiClass -> Int -> Maybe Name+biClassConstraint Bifunctor 1 = Just functorTypeName+biClassConstraint Bifoldable 1 = Just foldableTypeName+biClassConstraint Bitraversable 1 = Just traversableTypeName+biClassConstraint biClass 2 = Just $ biClassName biClass+biClassConstraint _ _ = Nothing++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++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 [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 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)++In a derived Bifoldable T instance, you would generate the following bifoldMap+definition:++ bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2++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+ | UnboxedTupleT len <- f+ -> tuple $ Unboxed len+ | 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)+ go_kind = go++ 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+ -- Use an underscore in front of the variable name, as it's possible for+ -- certain Bifoldable instances to generate code like this (see #89):+ --+ -- @+ -- bifoldMap (\\_n -> mempty) ...+ -- @+ --+ -- Without the underscore, that code would trigger -Wunused-matches warnings.+ n <- newName "_n"+ lamE [varP n] $ lam (VarE n)++-- Make a 'LamE' using two fresh variables.+mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp+mkSimpleLam2 lam = do+ -- Use an underscore in front of the variable name, as it's possible for+ -- certain Bifoldable instances to generate code like this (see #89):+ --+ -- @+ -- bifoldr (\\_n1 n2 -> n2) ...+ -- @+ --+ -- Without the underscore, that code would trigger -Wunused-matches warnings.+ n1 <- newName "_n1"+ n2 <- newName "n2"+ lamE [varP n1, varP n2] $ lam (VarE n1) (VarE n2)++-- "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 = conPCompat 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 = conPCompat conName (map VarP varsNeeded)+ -- Make sure to zip BEFORE invoking catMaybes. We want the variable+ -- indices 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+ | Unboxed Int++-- "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+ Unboxed len -> unboxedTupleDataName len+ m <- matchForCon tupDataName insides+ return $ CaseE x [m]++-- Adapt to the type of ConP changing in template-haskell-2.18.0.0.+conPCompat :: Name -> [Pat] -> Pat+conPCompat n pats = ConP n+#if MIN_VERSION_template_haskell(2,18,0)+ []+#endif+ pats
src/Data/Bifunctor/TH/Internal.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Unsafe #-}-#endif {-| Module: Data.Bifunctor.TH.Internal@@ -15,101 +12,33 @@ -} module Data.Bifunctor.TH.Internal where -import Control.Monad (liftM)--import Data.Bifunctor (bimap)+import Control.Applicative+import Data.Bifunctor (Bifunctor(..))+import Data.Bifoldable (Bifoldable(..))+import Data.Bitraversable (Bitraversable(..))+import Data.Coerce (coerce) import Data.Foldable (foldr')-import Data.List-import qualified Data.Map as Map (fromList, findWithDefault, singleton)+import qualified Data.List as List+import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe)+import Data.Monoid (Dual(..), Endo(..)) 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 --- Ensure, beyond a shadow of a doubt, that the instances are in-scope-import Data.Bifunctor ()-import Data.Bifoldable ()-import Data.Bitraversable ()--#ifndef CURRENT_PACKAGE_KEY-import Data.Version (showVersion)-import Paths_bifunctors (version)-#endif- ------------------------------------------------------------------------------- -- 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-#if MIN_VERSION_template_haskell(2,8,0)-substKind = substType-#else-substKind _ = id -- There are no kind variables!-#endif+applySubstitutionKind :: Map Name Kind -> Type -> Type+applySubstitutionKind = applySubstitution 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@@ -149,9 +78,7 @@ canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of-#if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k-#endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.@@ -169,21 +96,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@@ -225,56 +137,18 @@ 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-#if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#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 +156,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 +164,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,38 +173,19 @@ 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) applyClass con t = AppT (ConT con) (VarT t)-#else-applyClass con t = ClassP con [VarT t]-#endif -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions:@@ -380,23 +226,37 @@ 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-#if MIN_VERSION_template_haskell(2,11,0)- FamilyI OpenTypeFamilyD{} _ -> True-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ _ _) _ -> True-#else- TyConI (FamilyD TypeFam _ _ _) -> True-#endif-#if MIN_VERSION_template_haskell(2,9,0)- FamilyI ClosedTypeFamilyD{} _ -> True-#endif- _ -> False-isTyFamily _ = return False+-- | 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+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> withinFirstArgs bndrs+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> withinFirstArgs bndrs+ _ -> 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? --@@ -416,25 +276,17 @@ where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names- go (SigT t _k) names = go t names-#if MIN_VERSION_template_haskell(2,8,0)- || go _k names-#endif+ go (SigT t k) names = go t names || go k names go (VarT n) names = n `elem` names go _ _ = False -- | Does an instance predicate mention any of the Names in the list? predMentionsName :: Pred -> [Name] -> Bool-#if MIN_VERSION_template_haskell(2,10,0) predMentionsName = mentionsName-#else-predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys-predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names-#endif -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type-applyTy = foldl' AppT+applyTy = List.foldl' AppT -- | Fully applies a type constructor to its type variables. applyTyCon :: Name -> [Type] -> Type@@ -451,14 +303,15 @@ -- @ -- [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+ 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+ go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this: --@@ -483,174 +336,113 @@ -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind]-#if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy-#else-uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2-uncurryKind k = [k]-#endif ---------------------------------------------------------------------------------- Manually quoted names+-- Quoted names ------------------------------------------------------------------------------- --- By manually generating these names we avoid needing to use the--- TemplateHaskell language extension when compiling the bifunctors library.--- This allows the library to be used in stage1 cross-compilers.--bifunctorsPackageKey :: String-#ifdef CURRENT_PACKAGE_KEY-bifunctorsPackageKey = CURRENT_PACKAGE_KEY-#else-bifunctorsPackageKey = "bifunctors-" ++ showVersion version-#endif--mkBifunctorsName_tc :: String -> String -> Name-mkBifunctorsName_tc = mkNameG_tc bifunctorsPackageKey--mkBifunctorsName_v :: String -> String -> Name-mkBifunctorsName_v = mkNameG_v bifunctorsPackageKey- bimapConstValName :: Name-bimapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bimapConst"+bimapConstValName = 'bimapConst bifoldrConstValName :: Name-bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst"+bifoldrConstValName = 'bifoldrConst bifoldMapConstValName :: Name-bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst"--bitraverseConstValName :: Name-bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst"+bifoldMapConstValName = 'bifoldMapConst -dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"+coerceValName :: Name+coerceValName = 'coerce -endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"+bitraverseConstValName :: Name+bitraverseConstValName = 'bitraverseConst wrapMonadDataName :: Name-wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"+wrapMonadDataName = 'WrapMonad functorTypeName :: Name-functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"+functorTypeName = ''Functor foldableTypeName :: Name-foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"+foldableTypeName = ''Foldable traversableTypeName :: Name-traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"--appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"+traversableTypeName = ''Traversable composeValName :: Name-composeValName = mkNameG_v "base" "GHC.Base" "."+composeValName = '(.) idValName :: Name-idValName = mkNameG_v "base" "GHC.Base" "id"+idValName = 'id errorValName :: Name-errorValName = mkNameG_v "base" "GHC.Err" "error"+errorValName = 'error flipValName :: Name-flipValName = mkNameG_v "base" "GHC.Base" "flip"+flipValName = 'flip fmapValName :: Name-fmapValName = mkNameG_v "base" "GHC.Base" "fmap"+fmapValName = 'fmap foldrValName :: Name-foldrValName = mkNameG_v "base" "Data.Foldable" "foldr"+foldrValName = 'foldr foldMapValName :: Name-foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap"+foldMapValName = 'foldMap -getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"+seqValName :: Name+seqValName = 'seq traverseValName :: Name-traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"+traverseValName = 'traverse 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+unwrapMonadValName = 'unwrapMonad -#if MIN_VERSION_base(4,8,0) bifunctorTypeName :: Name-bifunctorTypeName = mkNameG_tc "base" "Data.Bifunctor" "Bifunctor"--bimapValName :: Name-bimapValName = mkNameG_v "base" "Data.Bifunctor" "bimap"--pureValName :: Name-pureValName = mkNameG_v "base" "GHC.Base" "pure"--apValName :: Name-apValName = mkNameG_v "base" "GHC.Base" "<*>"--liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2"--mappendValName :: Name-mappendValName = mkNameG_v "base" "GHC.Base" "mappend"--memptyValName :: Name-memptyValName = mkNameG_v "base" "GHC.Base" "mempty"-#else-bifunctorTypeName :: Name-bifunctorTypeName = mkBifunctorsName_tc "Data.Bifunctor" "Bifunctor"+bifunctorTypeName = ''Bifunctor bimapValName :: Name-bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap"+bimapValName = 'bimap pureValName :: Name-pureValName = mkNameG_v "base" "Control.Applicative" "pure"+pureValName = 'pure apValName :: Name-apValName = mkNameG_v "base" "Control.Applicative" "<*>"+apValName = '(<*>) liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"+liftA2ValName = 'liftA2 mappendValName :: Name-mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"+mappendValName = 'mappend memptyValName :: Name-memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"-#endif+memptyValName = 'mempty -#if MIN_VERSION_base(4,10,0) bifoldableTypeName :: Name-bifoldableTypeName = mkNameG_tc "base" "Data.Bifoldable" "Bifoldable"+bifoldableTypeName = ''Bifoldable bitraversableTypeName :: Name-bitraversableTypeName = mkNameG_tc "base" "Data.Bitraversable" "Bitraversable"+bitraversableTypeName = ''Bitraversable bifoldrValName :: Name-bifoldrValName = mkNameG_v "base" "Data.Bifoldable" "bifoldr"+bifoldrValName = 'bifoldr bifoldMapValName :: Name-bifoldMapValName = mkNameG_v "base" "Data.Bifoldable" "bifoldMap"+bifoldMapValName = 'bifoldMap bitraverseValName :: Name-bitraverseValName = mkNameG_v "base" "Data.Bitraversable" "bitraverse"-#else-bifoldableTypeName :: Name-bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable"+bitraverseValName = 'bitraverse -bitraversableTypeName :: Name-bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable"+appEndoValName :: Name+appEndoValName = 'appEndo -bifoldrValName :: Name-bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr"+dualDataName :: Name+dualDataName = 'Dual -bifoldMapValName :: Name-bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap"+endoDataName :: Name+endoDataName = 'Endo -bitraverseValName :: Name-bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse"-#endif+getDualValName :: Name+getDualValName = 'getDual
src/Data/Bifunctor/Tannen.hs view
@@ -1,25 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif- ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett@@ -42,62 +29,53 @@ import Data.Bifunctor as B import Data.Bifunctor.Functor+import Data.Bifunctor.Swap (Swap (..)) import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif+import Data.Foldable1 (Foldable1(..))+import Data.Functor.Classes -#if __GLASGOW_HASKELL__ >= 702 import GHC.Generics-#endif import Prelude hiding ((.),id) -- | Compose a 'Functor' on the outside of a 'Bifunctor'. newtype Tannen f p a b = Tannen { runTannen :: f (p a b) }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable-#endif- )-#if __GLASGOW_HASKELL__ >= 702-# if __GLASGOW_HASKELL__ >= 708+ deriving (Eq, Ord, Show, Read, Generic) deriving instance Functor f => Generic1 (Tannen f p a)-# else-data TannenMetaData-data TannenMetaCons-data TannenMetaSel -instance Datatype TannenMetaData where- datatypeName _ = "Tannen"- moduleName _ = "Data.Bifunctor.Tannen"+instance (Eq1 f, Eq2 p, Eq a) => Eq1 (Tannen f p a) where+ liftEq = liftEq2 (==)+instance (Eq1 f, Eq2 p) => Eq2 (Tannen f p) where+ liftEq2 f g (Tannen x) (Tannen y) = liftEq (liftEq2 f g) x y -instance Constructor TannenMetaCons where- conName _ = "Tannen"- conIsRecord _ = True+instance (Ord1 f, Ord2 p, Ord a) => Ord1 (Tannen f p a) where+ liftCompare = liftCompare2 compare+instance (Ord1 f, Ord2 p) => Ord2 (Tannen f p) where+ liftCompare2 f g (Tannen x) (Tannen y) = liftCompare (liftCompare2 f g) x y -instance Selector TannenMetaSel where- selName _ = "runTannen"+instance (Read1 f, Read2 p, Read a) => Read1 (Tannen f p a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Read1 f, Read2 p) => Read2 (Tannen f p) where+ liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do+ ("Tannen", s1) <- lex s0+ ("{", s2) <- lex s1+ ("runTannen", s3) <- lex s2+ (x, s4) <- liftReadsPrec (liftReadsPrec2 rp1 rl1 rp2 rl2)+ (liftReadList2 rp1 rl1 rp2 rl2) 0 s3+ ("}", s5) <- lex s4+ return (Tannen x, s5) -instance Functor f => Generic1 (Tannen f p a) where- type Rep1 (Tannen f p a) = D1 TannenMetaData (C1 TannenMetaCons- (S1 TannenMetaSel (f :.: Rec1 (p a))))- from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runTannen- to1 = Tannen . fmap unRec1 . unComp1 . unM1 . unM1 . unM1-# endif-#endif+instance (Show1 f, Show2 p, Show a) => Show1 (Tannen f p a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance (Show1 f, Show2 p) => Show2 (Tannen f p) where+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (Tannen x) = showParen (p > 10) $+ showString "Tannen {runTannen = "+ . liftShowsPrec (liftShowsPrec2 sp1 sl1 sp2 sl2)+ (liftShowList2 sp1 sl1 sp2 sl2) 0 x+ . showChar '}' instance Functor f => BifunctorFunctor (Tannen f) where bifmap f (Tannen fp) = Tannen (fmap f fp)@@ -137,6 +115,10 @@ bifoldMap f g = foldMap (bifoldMap f g) . runTannen {-# INLINE bifoldMap #-} +instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where+ bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen+ {-# INLINE bifoldMap1 #-}+ instance (Traversable f, Bitraversable p) => Traversable (Tannen f p a) where traverse f = fmap Tannen . traverse (bitraverse pure f) . runTannen {-# INLINE traverse #-}@@ -171,3 +153,6 @@ instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g) +-- | @since 5.6.1+instance (Functor f, Swap p) => Swap (Tannen f p) where+ swap = Tannen . fmap swap . runTannen
src/Data/Bifunctor/Wrapped.hs view
@@ -1,21 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -31,63 +18,45 @@ ( WrappedBifunctor(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702+import Data.Functor.Classes import GHC.Generics-#endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. newtype WrappedBifunctor p a b = WrapBifunctor { unwrapBifunctor :: p a b }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data WrappedBifunctorMetaData-data WrappedBifunctorMetaCons-data WrappedBifunctorMetaSel+ deriving (Eq, Ord, Show, Read, Generic, Generic1) -instance Datatype WrappedBifunctorMetaData where- datatypeName = const "WrappedBifunctor"- moduleName = const "Data.Bifunctor.Wrapped"+instance (Eq2 p, Eq a) => Eq1 (WrappedBifunctor p a) where+ liftEq = liftEq2 (==)+instance Eq2 p => Eq2 (WrappedBifunctor p) where+ liftEq2 f g (WrapBifunctor x) (WrapBifunctor y) = liftEq2 f g x y -instance Constructor WrappedBifunctorMetaCons where- conName = const "WrapBifunctor"- conIsRecord = const True+instance (Ord2 p, Ord a) => Ord1 (WrappedBifunctor p a) where+ liftCompare = liftCompare2 compare+instance Ord2 p => Ord2 (WrappedBifunctor p) where+ liftCompare2 f g (WrapBifunctor x) (WrapBifunctor y) = liftCompare2 f g x y -instance Selector WrappedBifunctorMetaSel where- selName = const "unwrapBifunctor"+instance (Read2 p, Read a) => Read1 (WrappedBifunctor p a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance Read2 p => Read2 (WrappedBifunctor p) where+ liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do+ ("WrapBifunctor", s1) <- lex s0+ ("{", s2) <- lex s1+ ("unwrapBifunctor", s3) <- lex s2+ (x, s4) <- liftReadsPrec2 rp1 rl1 rp2 rl2 0 s3+ ("}", s5) <- lex s4+ return (WrapBifunctor x, s5) -instance Generic1 (WrappedBifunctor p a) where- type Rep1 (WrappedBifunctor p a) = D1 WrappedBifunctorMetaData- (C1 WrappedBifunctorMetaCons- (S1 WrappedBifunctorMetaSel (Rec1 (p a))))- from1 = M1 . M1 . M1 . Rec1 . unwrapBifunctor- to1 = WrapBifunctor . unRec1 . unM1 . unM1 . unM1-#endif+instance (Show2 p, Show a) => Show1 (WrappedBifunctor p a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+instance Show2 p => Show2 (WrappedBifunctor p) where+ liftShowsPrec2 sp1 sl1 sp2 sl2 p (WrapBifunctor x) = showParen (p > 10) $+ showString "WrapBifunctor {unwrapBifunctor = "+ . liftShowsPrec2 sp1 sl1 sp2 sl2 0 x+ . showChar '}' instance Bifunctor p => Bifunctor (WrappedBifunctor p) where first f = WrapBifunctor . first f . unwrapBifunctor@@ -114,6 +83,10 @@ instance Bifoldable p => Bifoldable (WrappedBifunctor p) where bifoldMap f g = bifoldMap f g . unwrapBifunctor {-# INLINE bifoldMap #-}++instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where+ bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor+ {-# INLINE bifoldMap1 #-} instance Bitraversable p => Traversable (WrappedBifunctor p a) where traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor
tests/BifunctorSpec.hs view
@@ -1,19 +1,26 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -fno-warn-unused-foralls #-}-#endif +{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+{-# OPTIONS_GHC -Wno-unused-foralls #-}+ {-| Module: BifunctorSpec Copyright: (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott@@ -31,7 +38,7 @@ import Data.Bitraversable import Data.Char (chr)-import Data.Functor.Classes (Eq1)+import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Monoid@@ -42,12 +49,6 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary) -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative (Applicative(..))-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-#endif- ------------------------------------------------------------------------------- -- Adapted from the test cases from@@ -61,6 +62,7 @@ | T3 [[a]] [[b]] [[c]] -- nested lists | T4 (c,(b,b),(c,c)) -- tuples | T5 ([c],Strange a b c) -- tycons+ deriving (Functor, Foldable, Traversable) type IntFun a b = (b -> Int) -> a data StrangeFunctions a b c@@ -68,6 +70,7 @@ | T7 (a -> (c,a)) -- functions and tuples | T8 ((b -> a) -> c) -- continuation | T9 (IntFun b c) -- type synonyms+ deriving Functor data StrangeGADT a b where T10 :: Ord d => d -> StrangeGADT c d@@ -76,35 +79,101 @@ T13 :: i ~ Int => Int -> StrangeGADT h i T14 :: k ~ Int => k -> StrangeGADT j k T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n+instance Foldable (StrangeGADT a) where+ foldMap f (T10 x) = f x+ foldMap f (T11 _) = mempty+ foldMap f (T12 _) = mempty+ foldMap f (T13 _) = mempty+ foldMap f (T14 x) = f x+ foldMap f (T15 _ _) = mempty data NotPrimitivelyRecursive a b = S1 (NotPrimitivelyRecursive (a,a) (b, a)) | S2 a | S3 b+ deriving (Functor, Foldable, Traversable) newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b))- deriving (Arbitrary, Eq, Show)+ deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable) newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b))+instance (Bifunctor (f Int), Functor g) =>+ Functor (ComplexConstraint f g a) where+ fmap f (ComplexConstraint x) =+ ComplexConstraint (bimap id (\(ga,a,b) -> (ga,a,f b)) x)+instance (Bifoldable (f Int), Foldable g) =>+ Foldable (ComplexConstraint f g a) where+ foldMap f (ComplexConstraint x) =+ bifoldMap (const mempty) (\(_,_,b) -> f b) x+instance (Bitraversable (f Int), Traversable g) =>+ Traversable (ComplexConstraint f g a) where+ traverse f (ComplexConstraint x) =+ ComplexConstraint `fmap` bitraverse pure (\(ga,a,b) -> (ga,a,) `fmap` f b) x data Universal a b = Universal (forall b. (b,[a])) | Universal2 (forall f. Bifunctor f => f a b) | Universal3 (forall a. Maybe a) -- reuse a | NotReallyUniversal (forall b. a)+instance Functor (Universal a) where+ fmap f (Universal x) = Universal x+ fmap f (Universal2 x) = Universal2 (bimap id f x)+ fmap f (Universal3 x) = Universal3 x+ fmap f (NotReallyUniversal x) = NotReallyUniversal x data Existential a b = forall a. ExistentialList [a] | forall f. Bitraversable f => ExistentialFunctor (f a b) | forall b. SneakyUseSameName (Maybe b)+instance Functor (Existential a) where+ fmap f (ExistentialList x) = ExistentialList x+ fmap f (ExistentialFunctor x) = ExistentialFunctor (bimap id f x)+ fmap f (SneakyUseSameName x) = SneakyUseSameName x+instance Foldable (Existential a) where+ foldMap f (ExistentialList _) = mempty+ foldMap f (ExistentialFunctor x) = bifoldMap (const mempty) f x+ foldMap f (SneakyUseSameName _) = mempty+instance Traversable (Existential a) where+ traverse f (ExistentialList x) = pure $ ExistentialList x+ traverse f (ExistentialFunctor x) = ExistentialFunctor `fmap` bitraverse pure f x+ traverse f (SneakyUseSameName x) = pure $ SneakyUseSameName x data IntHash a b = IntHash Int# Int# | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int))+ deriving (Functor, Foldable)+instance Traversable (IntHash a) where+ traverse f (IntHash x y) = pure (IntHash x y)+ traverse f (IntHashTuple x y z (a,b,c,d)) =+ (\z' b' d' -> IntHashTuple x y z' (a,b',c,d'))+ `fmap` f z+ <*> f b+ <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a)+ deriving Functor +data Empty1 a b+ deriving (Functor, Foldable, Traversable)++data Empty2 a b+ deriving (Functor, Foldable, Traversable)+type role Empty2 nominal nominal++data TyCon81 a b+ = TyCon81a (forall c. c -> (forall d. a -> d) -> a)+ | TyCon81b (Int -> forall c. c -> b)+instance Functor (TyCon81 a) where+ fmap f (TyCon81a g) = TyCon81a g+ fmap f (TyCon81b g) = TyCon81b (\x y -> f (g x y))++type family F :: * -> * -> *+type instance F = Either++data TyCon82 a b = TyCon82 (F a b)+ deriving (Functor, Foldable, Traversable)+ -- Data families data family StrangeFam x y z@@ -114,6 +183,7 @@ | T3Fam [[a]] [[b]] [[c]] -- nested lists | T4Fam (c,(b,b),(c,c)) -- tuples | T5Fam ([c],Strange a b c) -- tycons+ deriving (Functor, Foldable, Traversable) data family StrangeFunctionsFam x y z data instance StrangeFunctionsFam a b c@@ -121,6 +191,7 @@ | T7Fam (a -> (c,a)) -- functions and tuples | T8Fam ((b -> a) -> c) -- continuation | T9Fam (IntFun b c) -- type synonyms+ deriving Functor data family StrangeGADTFam x y data instance StrangeGADTFam a b where@@ -130,19 +201,41 @@ T13Fam :: i ~ Int => Int -> StrangeGADTFam h i T14Fam :: k ~ Int => k -> StrangeGADTFam j k T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n+instance Foldable (StrangeGADTFam a) where+ foldMap f (T10Fam x) = f x+ foldMap f (T11Fam _) = mempty+ foldMap f (T12Fam _) = mempty+ foldMap f (T13Fam _) = mempty+ foldMap f (T14Fam x) = f x+ foldMap f (T15Fam _ _) = mempty data family NotPrimitivelyRecursiveFam x y data instance NotPrimitivelyRecursiveFam a b = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) | S2Fam a | S3Fam b+ deriving (Functor, Foldable, Traversable) data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b))- deriving (Arbitrary, Eq, Show)+ deriving ( Arbitrary, Eq, Show+ , Functor, Foldable, Traversable+ ) data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b))+instance (Bifunctor (f Int), Functor g) =>+ Functor (ComplexConstraintFam f g a) where+ fmap f (ComplexConstraintFam x) =+ ComplexConstraintFam (bimap id (\(ga,a,b) -> (ga,a,f b)) x)+instance (Bifoldable (f Int), Foldable g) =>+ Foldable (ComplexConstraintFam f g a) where+ foldMap f (ComplexConstraintFam x) =+ bifoldMap (const mempty) (\(_,_,b) -> f b) x+instance (Bitraversable (f Int), Traversable g) =>+ Traversable (ComplexConstraintFam f g a) where+ traverse f (ComplexConstraintFam x) =+ ComplexConstraintFam `fmap` bitraverse pure (\(ga,a,b) -> (ga,a,) `fmap` f b) x data family UniversalFam x y data instance UniversalFam a b@@ -150,22 +243,53 @@ | Universal2Fam (forall f. Bifunctor f => f a b) | Universal3Fam (forall a. Maybe a) -- reuse a | NotReallyUniversalFam (forall b. a)+instance Functor (UniversalFam a) where+ fmap f (UniversalFam x) = UniversalFam x+ fmap f (Universal2Fam x) = Universal2Fam (bimap id f x)+ fmap f (Universal3Fam x) = Universal3Fam x+ fmap f (NotReallyUniversalFam x) = NotReallyUniversalFam x data family ExistentialFam x y data instance ExistentialFam a b = forall a. ExistentialListFam [a] | forall f. Bitraversable f => ExistentialFunctorFam (f a b) | forall b. SneakyUseSameNameFam (Maybe b)+instance Functor (ExistentialFam a) where+ fmap f (ExistentialListFam x) = ExistentialListFam x+ fmap f (ExistentialFunctorFam x) = ExistentialFunctorFam (bimap id f x)+ fmap f (SneakyUseSameNameFam x) = SneakyUseSameNameFam x+instance Foldable (ExistentialFam a) where+ foldMap f (ExistentialListFam _) = mempty+ foldMap f (ExistentialFunctorFam x) = bifoldMap (const mempty) f x+ foldMap f (SneakyUseSameNameFam _) = mempty+instance Traversable (ExistentialFam a) where+ traverse f (ExistentialListFam x) = pure $ ExistentialListFam x+ traverse f (ExistentialFunctorFam x) = ExistentialFunctorFam `fmap` bitraverse pure f x+ traverse f (SneakyUseSameNameFam x) = pure $ SneakyUseSameNameFam x data family IntHashFam x y data instance IntHashFam a b = IntHashFam Int# Int# | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int))+ deriving (Functor, Foldable, Traversable) data family IntHashFunFam x y data instance IntHashFunFam a b = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)+ deriving Functor +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)+instance Functor (TyFamily81 a) where+ fmap f (TyFamily81a g) = TyFamily81a g+ fmap f (TyFamily81b g) = TyFamily81b (\x y -> f (g x y))++data family TyFamily82 x y+data instance TyFamily82 a b = TyFamily82 (F a b)+ deriving (Functor, Foldable, Traversable)+ ------------------------------------------------------------------------------- -- Plain data types@@ -188,14 +312,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,7 +349,21 @@ $(deriveBifunctor ''IntHashFun) -#if MIN_VERSION_template_haskell(2,7,0)+$(deriveBifunctor ''Empty1)+$(deriveBifoldable ''Empty1)+$(deriveBitraversable ''Empty1)++-- Use EmptyCase here+$(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)+$(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)+$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)++$(deriveBifunctor ''TyCon81)++$(deriveBifunctor ''TyCon82)+$(deriveBifoldable ''TyCon82)+$(deriveBitraversable ''TyCon82)+ -- Data families $(deriveBifunctor 'T1Fam)@@ -229,14 +384,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)@@ -248,46 +420,54 @@ $(deriveBitraversable 'IntHashFam) $(deriveBifunctor 'IntHashFunFam)-#endif +$(deriveBifunctor 'TyFamily81a)++$(deriveBifunctor 'TyFamily82)+$(deriveBifoldable 'TyFamily82)+$(deriveBitraversable 'TyFamily82)+ ------------------------------------------------------------------------------- -prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d))- => (a -> c) -> (b -> d) -> p a b -> Bool-prop_BifunctorLaws f g x =- bimap id id x == x- && first id x == x- && second id x == x- && bimap f g x == (first f . second g) x+prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d), Show (p a b), Show (p c d))+ => (a -> c) -> (b -> d) -> p a b -> Expectation+prop_BifunctorLaws f g x = do+ bimap id id x `shouldBe` x+ first id x `shouldBe` x+ second id x `shouldBe` x+ bimap f g x `shouldBe` (first f . second g) x -prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int])) => p [Int] [Int] -> Bool+prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42]) -prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Bifoldable p)+prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z,+ Monoid a, Monoid b, Bifoldable p) => (a -> b) -> (a -> b) -> (a -> z -> z) -> (a -> z -> z)- -> z -> p a a -> Bool-prop_BifoldableLaws f g h i z x =- bifold x == bifoldMap id id x- && bifoldMap f g x == bifoldr (mappend . f) (mappend . g) mempty x- && bifoldr h i z x == appEndo (bifoldMap (Endo . h) (Endo . i) x) z+ -> z -> p a a -> Expectation+prop_BifoldableLaws f g h i z x = do+ bifold x `shouldBe` bifoldMap id id x+ bifoldMap f g x `shouldBe` bifoldr (mappend . f) (mappend . g) mempty x+ bifoldr h i z x `shouldBe` appEndo (bifoldMap (Endo . h) (Endo . i) x) z -prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Bool+prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Expectation prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0 prop_BitraversableLaws :: (Applicative f, Applicative g, Bitraversable p,- Eq (g (p c c)), Eq (p a b), Eq (p d e), Eq1 f)+ Eq (g (p c c)), Eq (p a b), Eq (p d e), Eq1 f,+ Show (g (p c c)), Show (p a b), Show (p d e), Show1 f) => (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e)- -> (forall x. f x -> g x) -> p a b -> Bool-prop_BitraversableLaws f g h i t x =- bitraverse (t . f) (t . g) x == (t . bitraverse f g) x- && bitraverse Identity Identity x == Identity x- && (Compose . fmap (bitraverse h i) . bitraverse f g) x- == bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x+ -> (forall x. f x -> g x) -> p a b -> Expectation+prop_BitraversableLaws f g h i t x = do+ bitraverse (t . f) (t . g) x `shouldBe` (t . bitraverse f g) x+ bitraverse Identity Identity x `shouldBe` Identity x+ (Compose . fmap (bitraverse h i) . bitraverse f g) x+ `shouldBe` bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x -prop_BitraversableEx :: (Bitraversable p, Eq (p Char Char),- Eq (p [Char] [Char]), Eq (p [Int] [Int]))- => p [Int] [Int] -> Bool+prop_BitraversableEx :: (Bitraversable p,+ Eq (p Char Char), Eq (p [Char] [Char]), Eq (p [Int] [Int]),+ Show (p Char Char), Show (p [Char] [Char]), Show (p [Int] [Int]))+ => p [Int] [Int] -> Expectation prop_BitraversableEx = prop_BitraversableLaws (replicate 2 . map (chr . abs)) (replicate 4 . map (chr . abs))@@ -304,17 +484,15 @@ spec = do describe "OneTwoCompose Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws"- (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)+ (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bifoldable laws"- (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)+ (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws"- (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)-#if MIN_VERSION_template_haskell(2,7,0)+ (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws"- (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)+ (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bifoldable laws"- (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)+ (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws"- (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)-#endif+ (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)
+ tests/T89Spec.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++-- | A regression test for #89 which ensures that a TH-generated Bifoldable+-- instance of a certain shape does not trigger -Wunused-matches warnings.+module T89Spec where++import Data.Bifunctor.TH+import Test.Hspec++data X = MkX+data Y a b = MkY a b+newtype XY a b = XY { getResp :: Either X (Y a b) }++$(deriveBifoldable ''Y)+$(deriveBifoldable ''XY)++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()