bifunctors 5.5.14 → 5.5.15
raw patch · 27 files changed
+6057/−6041 lines, 27 filesdep ~template-haskelldep ~th-abstractionsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell, th-abstraction
API changes (from Hackage documentation)
Files
- CHANGELOG.markdown +188/−184
- LICENSE +26/−26
- README.markdown +13/−13
- Setup.lhs +7/−7
- bifunctors.cabal +141/−139
- include/bifunctors-common.h +19/−19
- old-src/ghc709/Data/Bifunctor.hs +185/−185
- old-src/ghc801/Data/Bifoldable.hs +487/−487
- old-src/ghc801/Data/Bitraversable.hs +320/−320
- src/Data/Biapplicative.hs +327/−327
- src/Data/Bifunctor/Biap.hs +169/−169
- src/Data/Bifunctor/Biff.hs +167/−167
- src/Data/Bifunctor/Clown.hs +192/−192
- src/Data/Bifunctor/Fix.hs +120/−120
- src/Data/Bifunctor/Flip.hs +139/−139
- src/Data/Bifunctor/Functor.hs +57/−57
- src/Data/Bifunctor/Join.hs +123/−123
- src/Data/Bifunctor/Joker.hs +191/−191
- src/Data/Bifunctor/Product.hs +187/−187
- src/Data/Bifunctor/Sum.hs +146/−146
- src/Data/Bifunctor/TH.hs +1344/−1334
- src/Data/Bifunctor/TH/Internal.hs +574/−574
- src/Data/Bifunctor/Tannen.hs +211/−211
- src/Data/Bifunctor/Wrapped.hs +160/−160
- tests/BifunctorSpec.hs +542/−542
- tests/Spec.hs +1/−1
- tests/T89Spec.hs +21/−21
CHANGELOG.markdown view
@@ -1,184 +1,188 @@-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 avaiable 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) -* Backport slightly more efficient implementations of `bimapDefault` and `bifoldMapDefault` - -5.4.1 ------ -* Add explicit `Safe`, `Trustworthy`, and `Unsafe` annotations. In particular, annotate the `Data.Bifoldable` module as `Trustworthy` (previously, it was inferred to be `Unsafe`). - -5.4 ---- -* Only export `Data.Bifoldable` and `Data.Bitraversable` when building on GHC < 8.1, otherwise they come from `base` -* Allow TH derivation of `Bifunctor` and `Bifoldable` instances for datatypes containing unboxed tuple types - -5.3 ---- -* Added `bifoldr1`, `bifoldl1`, `bimsum`, `biasum`, `binull`, `bilength`, `bielem`, `bimaximum`, `biminimum`, `bisum`, `biproduct`, `biand`, `bior`, `bimaximumBy`, `biminimumBy`, `binotElem`, and `bifind` to `Data.Bifoldable` -* Added `Bifunctor`, `Bifoldable`, and `Bitraversable` instances for `GHC.Generics.K1` -* TH code no longer generates superfluous `mempty` or `pure` subexpressions in derived `Bifoldable` or `Bitraversable` instances, respectively - -5.2.1 ----- -* Added `Bifoldable` and `Bitraversable` instances for `Constant` from `transformers` -* `Data.Bifunctor.TH` now compiles warning-free on GHC 8.0 - -5.2 ------ -* Added several `Arrow`-like instances for `Tannen` so we can use it as the Cayley construction if needed. -* Added `Data.Bifunctor.Sum` -* Added `BifunctorFunctor`, `BifunctorMonad` and `BifunctorComonad`. -* Backported `Bifunctor Constant` instance from `transformers` - -5.1 ---- -* Added `Data.Bifunctor.Fix` -* Added `Data.Bifunctor.TH`, which permits `TemplateHaskell`-based deriving of `Bifunctor`, `Bifoldable` and `Bitraversable` instances. -* Simplified `Bitraversable`. - -5 -- -* Inverted the dependency on `semigroupoids`. We can support a much wider array of `base` versions than it can. -* Added flags - -4.2.1 ------ -* Support `Arg` from `semigroups` 0.16.2 -* Fixed a typo. - -4.2 ---- -* Bumped dependency on `tagged`, which is required to build cleanly on GHC 7.9+ -* Only export `Data.Bifunctor` when building on GHC < 7.9, otherwise it comes from `base`. - -4.1.1.1 -------- -* Added documentation for 'Bifoldable' and 'Bitraversable' - -4.1.1 ------ -* Added `Data.Bifunctor.Join` -* Fixed improper lower bounds on `base` - -4.1.0.1 -------- -* Updated to BSD 2-clause license - -4.1 ---- -* Added product bifunctors - -4.0 ---- -* Compatibility with `semigroupoids` 4.0 - -3.2 ---- -* Added missing product instances for `Biapplicative` and `Biapply`. - -3.1 ------ -* Added `Data.Biapplicative`. -* Added the `Clown` and `Joker` bifunctors from Conor McBride's "Clowns to the left of me, Jokers to the right." -* Added instances for `Const`, higher tuples -* Added `Tagged` instances. - -3.0.4 ------ -* Added `Data.Bifunctor.Flip` and `Data.Bifunctor.Wrapped`. - -3.0.3 ---- -* Removed upper bounds from my other package dependencies +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 avaiable 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)+* Backport slightly more efficient implementations of `bimapDefault` and `bifoldMapDefault`++5.4.1+-----+* Add explicit `Safe`, `Trustworthy`, and `Unsafe` annotations. In particular, annotate the `Data.Bifoldable` module as `Trustworthy` (previously, it was inferred to be `Unsafe`).++5.4+---+* Only export `Data.Bifoldable` and `Data.Bitraversable` when building on GHC < 8.1, otherwise they come from `base`+* Allow TH derivation of `Bifunctor` and `Bifoldable` instances for datatypes containing unboxed tuple types++5.3+---+* Added `bifoldr1`, `bifoldl1`, `bimsum`, `biasum`, `binull`, `bilength`, `bielem`, `bimaximum`, `biminimum`, `bisum`, `biproduct`, `biand`, `bior`, `bimaximumBy`, `biminimumBy`, `binotElem`, and `bifind` to `Data.Bifoldable`+* Added `Bifunctor`, `Bifoldable`, and `Bitraversable` instances for `GHC.Generics.K1`+* TH code no longer generates superfluous `mempty` or `pure` subexpressions in derived `Bifoldable` or `Bitraversable` instances, respectively++5.2.1+----+* Added `Bifoldable` and `Bitraversable` instances for `Constant` from `transformers`+* `Data.Bifunctor.TH` now compiles warning-free on GHC 8.0++5.2+-----+* Added several `Arrow`-like instances for `Tannen` so we can use it as the Cayley construction if needed.+* Added `Data.Bifunctor.Sum`+* Added `BifunctorFunctor`, `BifunctorMonad` and `BifunctorComonad`.+* Backported `Bifunctor Constant` instance from `transformers`++5.1+---+* Added `Data.Bifunctor.Fix`+* Added `Data.Bifunctor.TH`, which permits `TemplateHaskell`-based deriving of `Bifunctor`, `Bifoldable` and `Bitraversable` instances.+* Simplified `Bitraversable`.++5+-+* Inverted the dependency on `semigroupoids`. We can support a much wider array of `base` versions than it can.+* Added flags++4.2.1+-----+* Support `Arg` from `semigroups` 0.16.2+* Fixed a typo.++4.2+---+* Bumped dependency on `tagged`, which is required to build cleanly on GHC 7.9++* Only export `Data.Bifunctor` when building on GHC < 7.9, otherwise it comes from `base`.++4.1.1.1+-------+* Added documentation for 'Bifoldable' and 'Bitraversable'++4.1.1+-----+* Added `Data.Bifunctor.Join`+* Fixed improper lower bounds on `base`++4.1.0.1+-------+* Updated to BSD 2-clause license++4.1+---+* Added product bifunctors++4.0+---+* Compatibility with `semigroupoids` 4.0++3.2+---+* Added missing product instances for `Biapplicative` and `Biapply`.++3.1+-----+* Added `Data.Biapplicative`.+* Added the `Clown` and `Joker` bifunctors from Conor McBride's "Clowns to the left of me, Jokers to the right."+* Added instances for `Const`, higher tuples+* Added `Tagged` instances.++3.0.4+-----+* Added `Data.Bifunctor.Flip` and `Data.Bifunctor.Wrapped`.++3.0.3+---+* Removed upper bounds from my other package dependencies
LICENSE view
@@ -1,26 +1,26 @@-Copyright 2008-2016 Edward Kmett - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +Copyright 2008-2016 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
README.markdown view
@@ -1,13 +1,13 @@-bifunctors -========== - -[](https://hackage.haskell.org/package/bifunctors) [](https://github.com/ekmett/bifunctors/actions?query=workflow%3AHaskell-CI) - -Contact Information -------------------- - -Contributions and bug reports are welcome! - -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. - --Edward Kmett +bifunctors+==========++[](https://hackage.haskell.org/package/bifunctors) [](https://github.com/ekmett/bifunctors/actions?query=workflow%3AHaskell-CI)++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell -> module Main (main) where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
bifunctors.cabal view
@@ -1,139 +1,141 @@-name: bifunctors -category: Data, Functors -version: 5.5.14 -license: BSD3 -cabal-version: >= 1.10 -license-file: LICENSE -author: Edward A. Kmett -maintainer: Edward A. Kmett <ekmett@gmail.com> -stability: provisional -homepage: http://github.com/ekmett/bifunctors/ -bug-reports: http://github.com/ekmett/bifunctors/issues -copyright: Copyright (C) 2008-2016 Edward A. Kmett -synopsis: Bifunctors -description: Bifunctors. -build-type: Simple -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 - , GHC == 9.2.2 -extra-source-files: - CHANGELOG.markdown - README.markdown - include/bifunctors-common.h - -source-repository head - type: git - location: https://github.com/ekmett/bifunctors.git - -flag semigroups - default: True - manual: True - description: - You can disable the use of the `semigroups` package using `-f-semigroups`. - . - Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - -flag tagged - default: True - manual: True - description: - You can disable the use of the `tagged` package using `-f-tagged`. - . - Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - -library - hs-source-dirs: src - include-dirs: include - includes: bifunctors-common.h - build-depends: - base >= 4.3 && < 5, - base-orphans >= 0.8.4 && < 1, - comonad >= 5.0.7 && < 6, - containers >= 0.2 && < 0.7, - template-haskell >= 2.4 && < 2.20, - th-abstraction >= 0.4.2.0 && < 0.5, - transformers >= 0.3 && < 0.7 - - if !impl(ghc > 8.2) - build-depends: transformers-compat >= 0.5 && < 0.8 - - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - - if flag(tagged) - build-depends: tagged >= 0.8.6 && < 1 - - if flag(semigroups) && !impl(ghc >= 8.0) - build-depends: semigroups >= 0.18.5 && < 1 - - if impl(ghc<7.9) - hs-source-dirs: old-src/ghc709 - exposed-modules: Data.Bifunctor - - if impl(ghc<8.1) - hs-source-dirs: old-src/ghc801 - exposed-modules: - Data.Bifoldable - Data.Bitraversable - - if impl(ghc>=7.2) && impl(ghc<7.5) - build-depends: ghc-prim == 0.2.0.0 - - exposed-modules: - Data.Biapplicative - Data.Bifunctor.Biap - Data.Bifunctor.Biff - Data.Bifunctor.Clown - Data.Bifunctor.Fix - Data.Bifunctor.Flip - Data.Bifunctor.Functor - Data.Bifunctor.Join - Data.Bifunctor.Joker - Data.Bifunctor.Product - Data.Bifunctor.Sum - Data.Bifunctor.Tannen - Data.Bifunctor.TH - Data.Bifunctor.Wrapped - - other-modules: - Data.Bifunctor.TH.Internal - Paths_bifunctors - - ghc-options: -Wall - 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 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 - +name: bifunctors+category: Data, Functors+version: 5.5.15+license: BSD3+cabal-version: >= 1.10+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/bifunctors/+bug-reports: http://github.com/ekmett/bifunctors/issues+copyright: Copyright (C) 2008-2016 Edward A. Kmett+synopsis: Bifunctors+description: Bifunctors.+build-type: Simple+tested-with: GHC == 7.0.4+ , GHC == 7.2.2+ , GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.6+ , GHC == 9.4.4+ , GHC == 9.6.1+extra-source-files:+ CHANGELOG.markdown+ README.markdown+ include/bifunctors-common.h++source-repository head+ type: git+ location: https://github.com/ekmett/bifunctors.git++flag semigroups+ default: True+ manual: True+ description:+ You can disable the use of the `semigroups` package using `-f-semigroups`.+ .+ Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.++flag tagged+ default: True+ manual: True+ description:+ You can disable the use of the `tagged` package using `-f-tagged`.+ .+ Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.++library+ hs-source-dirs: src+ include-dirs: include+ includes: bifunctors-common.h+ build-depends:+ base >= 4.3 && < 5,+ base-orphans >= 0.8.4 && < 1,+ comonad >= 5.0.7 && < 6,+ containers >= 0.2 && < 0.7,+ template-haskell >= 2.4 && < 2.21,+ th-abstraction >= 0.4.2.0 && < 0.6,+ transformers >= 0.3 && < 0.7++ if !impl(ghc > 8.2)+ build-depends: transformers-compat >= 0.5 && < 0.8++ if !impl(ghc >= 8.0)+ build-depends: fail == 4.9.*++ if flag(tagged)+ build-depends: tagged >= 0.8.6 && < 1++ if flag(semigroups) && !impl(ghc >= 8.0)+ build-depends: semigroups >= 0.18.5 && < 1++ if impl(ghc<7.9)+ hs-source-dirs: old-src/ghc709+ exposed-modules: Data.Bifunctor++ if impl(ghc<8.1)+ hs-source-dirs: old-src/ghc801+ exposed-modules:+ Data.Bifoldable+ Data.Bitraversable++ if impl(ghc>=7.2) && impl(ghc<7.5)+ build-depends: ghc-prim == 0.2.0.0++ exposed-modules:+ Data.Biapplicative+ Data.Bifunctor.Biap+ Data.Bifunctor.Biff+ Data.Bifunctor.Clown+ Data.Bifunctor.Fix+ Data.Bifunctor.Flip+ Data.Bifunctor.Functor+ Data.Bifunctor.Join+ Data.Bifunctor.Joker+ Data.Bifunctor.Product+ Data.Bifunctor.Sum+ Data.Bifunctor.Tannen+ Data.Bifunctor.TH+ Data.Bifunctor.Wrapped++ other-modules:+ Data.Bifunctor.TH.Internal+ Paths_bifunctors++ ghc-options: -Wall+ 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 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+
include/bifunctors-common.h view
@@ -1,19 +1,19 @@-#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers_compat -#define MIN_VERSION_transformers_compat(x,y,z) 0 -#endif - -#if MIN_VERSION_base(4,9,0) -#define LIFTED_FUNCTOR_CLASSES 1 -#else -#if MIN_VERSION_transformers(0,5,0) -#define LIFTED_FUNCTOR_CLASSES 1 -#else -#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) -#define LIFTED_FUNCTOR_CLASSES 1 -#endif -#endif -#endif +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers_compat+#define MIN_VERSION_transformers_compat(x,y,z) 0+#endif++#if MIN_VERSION_base(4,9,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers(0,5,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)+#define LIFTED_FUNCTOR_CLASSES 1+#endif+#endif+#endif
old-src/ghc709/Data/Bifunctor.hs view
@@ -1,185 +1,185 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#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 -import Data.Semigroup - -#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 #-} - -instance Bifunctor Arg where - bimap f g (Arg a b) = Arg (f a) (g b) - -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) +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#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+import Data.Semigroup++#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 #-}++instance Bifunctor Arg where+ bimap f g (Arg a b) = Arg (f a) (g b)++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 view
@@ -1,487 +1,487 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#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 - -import Data.Semigroup (Arg(..)) - -#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 - -instance Bifoldable Arg where - bifoldMap f g (Arg a b) = f a `mappend` g b - -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. --} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#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++import Data.Semigroup (Arg(..))++#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++instance Bifoldable Arg where+ bifoldMap f g (Arg a b) = f a `mappend` g b++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 view
@@ -1,320 +1,320 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#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 - -import Data.Semigroup (Arg(..)) - -#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 --- ≡ 'bitraverse' ('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) - - --- | 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 - -instance Bitraversable Arg where - bitraverse f g (Arg a b) = Arg <$> f a <*> g b - -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 +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Trustworthy #-}+#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++import Data.Semigroup (Arg(..))++#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+-- ≡ 'bitraverse' ('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)+++-- | 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++instance Bitraversable Arg where+ bitraverse f g (Arg a b) = Arg <$> f a <*> g b++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,327 +1,327 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#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.Biapplicative ( - -- * Biapplicative bifunctors - Biapplicative(..) - , (<<$>>) - , (<<**>>) - , biliftA3 - , traverseBia - , sequenceBia - , traverseBiaWith - , module Data.Bifunctor - ) where - -import Control.Applicative -import Data.Bifunctor -import Data.Functor.Identity -import GHC.Exts (inline) - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -import Data.Traversable (Traversable (traverse)) -#endif - -import Data.Semigroup (Arg(..)) - -#ifdef MIN_VERSION_tagged -import Data.Tagged -#endif - -infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>> -(<<$>>) :: (a -> b) -> a -> b -(<<$>>) = id -{-# INLINE (<<$>>) #-} - -class Bifunctor p => Biapplicative p where -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-} -#endif - 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 = biliftA2 (const id) (const id) a b - {-# INLINE (*>>) #-} - - -- | - -- @ - -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b - -- @ - (<<*) :: p a b -> p c d -> p 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 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 = 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 'Biappicative' 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) - {-# INLINE (<<*>>) #-} - biliftA2 f g ~(x, y) ~(a, b) = (f x a, g y b) - {-# INLINE biliftA2 #-} - -instance Biapplicative Arg where - bipure = Arg - {-# INLINE bipure #-} - Arg f g <<*>> Arg a b = Arg (f a) (g b) - {-# INLINE (<<*>>) #-} - 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) - {-# 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) - {-# 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) - {-# 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) - {-# 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) - {-# INLINE (<<*>>) #-} - -#ifdef MIN_VERSION_tagged -instance Biapplicative Tagged where - bipure _ b = Tagged b - {-# INLINE bipure #-} - - Tagged f <<*>> Tagged x = Tagged (f x) - {-# INLINE (<<*>>) #-} -#endif - -instance Biapplicative Const where - bipure a _ = Const a - {-# INLINE bipure #-} - Const f <<*>> Const x = Const (f x) - {-# INLINE (<<*>>) #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#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.Biapplicative (+ -- * Biapplicative bifunctors+ Biapplicative(..)+ , (<<$>>)+ , (<<**>>)+ , biliftA3+ , traverseBia+ , sequenceBia+ , traverseBiaWith+ , module Data.Bifunctor+ ) where++import Control.Applicative+import Data.Bifunctor+import Data.Functor.Identity+import GHC.Exts (inline)++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid+import Data.Traversable (Traversable (traverse))+#endif++import Data.Semigroup (Arg(..))++#ifdef MIN_VERSION_tagged+import Data.Tagged+#endif++infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>>+(<<$>>) :: (a -> b) -> a -> b+(<<$>>) = id+{-# INLINE (<<$>>) #-}++class Bifunctor p => Biapplicative p where+#if __GLASGOW_HASKELL__ >= 708+ {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-}+#endif+ 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 = biliftA2 (const id) (const id) a b+ {-# INLINE (*>>) #-}++ -- |+ -- @+ -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b+ -- @+ (<<*) :: p a b -> p c d -> p 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 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 = 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 'Biappicative' 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)+ {-# INLINE (<<*>>) #-}+ biliftA2 f g ~(x, y) ~(a, b) = (f x a, g y b)+ {-# INLINE biliftA2 #-}++instance Biapplicative Arg where+ bipure = Arg+ {-# INLINE bipure #-}+ Arg f g <<*>> Arg a b = Arg (f a) (g b)+ {-# INLINE (<<*>>) #-}+ 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)+ {-# 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)+ {-# 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)+ {-# 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)+ {-# 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)+ {-# INLINE (<<*>>) #-}++#ifdef MIN_VERSION_tagged+instance Biapplicative Tagged where+ bipure _ b = Tagged b+ {-# INLINE bipure #-}++ Tagged f <<*>> Tagged x = Tagged (f x)+ {-# INLINE (<<*>>) #-}+#endif++instance Biapplicative Const where+ bipure a _ = Const a+ {-# INLINE bipure #-}+ Const f <<*>> Const x = Const (f x)+ {-# INLINE (<<*>>) #-}
src/Data/Bifunctor/Biap.hs view
@@ -1,169 +1,169 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - --- This module uses GND -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- 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 - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Foldable -import Data.Monoid -import Data.Traversable -#endif - -import qualified Data.Semigroup as S - --- | 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 -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 706 - , Generic1 -#endif - , Monad - , Fail.MonadFail - , MonadPlus - , Eq1 - , Ord1 - - , Bifunctor - , Biapplicative - , Bifoldable -#if LIFTED_FUNCTOR_CLASSES - , Eq2 - , Ord2 -#endif - ) - -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 -#if !(MIN_VERSION_base(4,5,0)) - -- Old versions of Num have Eq and Show as superclasses. Sigh. - , Eq (bi a b), Show (bi a b) -#endif - ) => 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) - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 -data BiapMetaData -data BiapMetaCons -data BiapMetaSel - -instance Datatype BiapMetaData where - datatypeName = const "Biap" - moduleName = const "Data.Bifunctor.Wrapped" - -instance Constructor BiapMetaCons where - conName = const "Biap" - conIsRecord = const True - -instance Selector BiapMetaSel where - selName = const "getBiap" - -instance Generic1 (Biap p a) where - type Rep1 (Biap p a) = D1 BiapMetaData - (C1 BiapMetaCons - (S1 BiapMetaSel (Rec1 (p a)))) - from1 = M1 . M1 . M1 . Rec1 . getBiap - to1 = Biap . unRec1 . unM1 . unM1 . unM1 -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif++-- This module uses GND+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- 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++#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++#if !(MIN_VERSION_base(4,8,0))+import Data.Foldable+import Data.Monoid+import Data.Traversable+#endif++import qualified Data.Semigroup as S++-- | 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+#if __GLASGOW_HASKELL__ >= 702+ , Generic+#endif+#if __GLASGOW_HASKELL__ >= 706+ , Generic1+#endif+ , Monad+ , Fail.MonadFail+ , MonadPlus+ , Eq1+ , Ord1++ , Bifunctor+ , Biapplicative+ , Bifoldable+#if LIFTED_FUNCTOR_CLASSES+ , Eq2+ , Ord2+#endif+ )++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+#if !(MIN_VERSION_base(4,5,0))+ -- Old versions of Num have Eq and Show as superclasses. Sigh.+ , Eq (bi a b), Show (bi a b)+#endif+ ) => 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)++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706+data BiapMetaData+data BiapMetaCons+data BiapMetaSel++instance Datatype BiapMetaData where+ datatypeName = const "Biap"+ moduleName = const "Data.Bifunctor.Wrapped"++instance Constructor BiapMetaCons where+ conName = const "Biap"+ conIsRecord = const True++instance Selector BiapMetaSel where+ selName = const "getBiap"++instance Generic1 (Biap p a) where+ type Rep1 (Biap p a) = D1 BiapMetaData+ (C1 BiapMetaCons+ (S1 BiapMetaSel (Rec1 (p a))))+ from1 = M1 . M1 . M1 . Rec1 . getBiap+ to1 = Biap . unRec1 . unM1 . unM1 . unM1+#endif
src/Data/Bifunctor/Biff.hs view
@@ -1,167 +1,167 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# 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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- 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.Biff - ( Biff(..) - ) 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.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 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 Constructor BiffMetaCons where - conName = const "Biff" - conIsRecord = const True - -instance Selector BiffMetaSel where - selName = const "runBiff" - -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 - -#if LIFTED_FUNCTOR_CLASSES -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 (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 (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 (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 '}' -#endif - -instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where - first f = Biff . first (fmap f) . runBiff - {-# INLINE first #-} - second f = Biff . second (fmap f) . runBiff - {-# INLINE second #-} - bimap f g = Biff . bimap (fmap f) (fmap g) . runBiff - {-# INLINE bimap #-} - -instance (Bifunctor p, Functor g) => Functor (Biff p f g a) where - fmap f = Biff . second (fmap f) . runBiff - {-# INLINE fmap #-} - -instance (Biapplicative p, Applicative f, Applicative g) => Biapplicative (Biff p f g) where - bipure a b = Biff (bipure (pure a) (pure b)) - {-# INLINE bipure #-} - - Biff fg <<*>> Biff xy = Biff (bimap (<*>) (<*>) fg <<*>> xy) - {-# INLINE (<<*>>) #-} - -instance (Bifoldable p, Foldable g) => Foldable (Biff p f g a) where - foldMap f = bifoldMap (const mempty) (foldMap f) . runBiff - {-# INLINE foldMap #-} - -instance (Bifoldable p, Foldable f, Foldable g) => Bifoldable (Biff p f g) where - bifoldMap f g = bifoldMap (foldMap f) (foldMap g) . runBiff - {-# INLINE bifoldMap #-} - -instance (Bitraversable p, Traversable g) => Traversable (Biff p f g a) where - traverse f = fmap Biff . bitraverse pure (traverse f) . runBiff - {-# INLINE traverse #-} - -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 #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- 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.Biff+ ( Biff(..)+ ) 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.Monoid+import Data.Traversable+#endif++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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 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 Constructor BiffMetaCons where+ conName = const "Biff"+ conIsRecord = const True++instance Selector BiffMetaSel where+ selName = const "runBiff"++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++#if LIFTED_FUNCTOR_CLASSES+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 (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 (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 (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 '}'+#endif++instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where+ first f = Biff . first (fmap f) . runBiff+ {-# INLINE first #-}+ second f = Biff . second (fmap f) . runBiff+ {-# INLINE second #-}+ bimap f g = Biff . bimap (fmap f) (fmap g) . runBiff+ {-# INLINE bimap #-}++instance (Bifunctor p, Functor g) => Functor (Biff p f g a) where+ fmap f = Biff . second (fmap f) . runBiff+ {-# INLINE fmap #-}++instance (Biapplicative p, Applicative f, Applicative g) => Biapplicative (Biff p f g) where+ bipure a b = Biff (bipure (pure a) (pure b))+ {-# INLINE bipure #-}++ Biff fg <<*>> Biff xy = Biff (bimap (<*>) (<*>) fg <<*>> xy)+ {-# INLINE (<<*>>) #-}++instance (Bifoldable p, Foldable g) => Foldable (Biff p f g a) where+ foldMap f = bifoldMap (const mempty) (foldMap f) . runBiff+ {-# INLINE foldMap #-}++instance (Bifoldable p, Foldable f, Foldable g) => Bifoldable (Biff p f g) where+ bifoldMap f g = bifoldMap (foldMap f) (foldMap g) . runBiff+ {-# INLINE bifoldMap #-}++instance (Bitraversable p, Traversable g) => Traversable (Biff p f g a) where+ traverse f = fmap Biff . bitraverse pure (traverse f) . runBiff+ {-# INLINE traverse #-}++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 #-}
src/Data/Bifunctor/Clown.hs view
@@ -1,192 +1,192 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2016 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" --- by Conor McBride. ----------------------------------------------------------------------------- -module Data.Bifunctor.Clown - ( Clown(..) - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - -import Data.Biapplicative -import Data.Bifoldable -import Data.Bitraversable -import Data.Functor.Classes - -#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 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 - ) - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data ClownMetaData -data ClownMetaCons -data ClownMetaSel - -instance Datatype ClownMetaData where - datatypeName _ = "Clown" - moduleName _ = "Data.Bifunctor.Clown" - -instance Constructor ClownMetaCons where - conName _ = "Clown" - conIsRecord _ = True - -instance Selector ClownMetaSel where - selName _ = "runClown" - -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 - -#if LIFTED_FUNCTOR_CLASSES -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 (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 (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 (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) -#else -instance (Eq1 f, Eq a) => Eq1 (Clown f a) where - eq1 = eqClown eq1 - -instance (Ord1 f, Ord a) => Ord1 (Clown f a) where - compare1 = compareClown compare1 - -instance (Read1 f, Read a) => Read1 (Clown f a) where - readsPrec1 = readsPrecClown readsPrec1 - -instance (Show1 f, Show a) => Show1 (Clown f a) where - showsPrec1 = showsPrecClown showsPrec1 -#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 #-} - second _ = Clown . runClown - {-# INLINE second #-} - bimap f _ = Clown . fmap f . runClown - {-# INLINE bimap #-} - -instance Functor (Clown f a) where - fmap _ = Clown . runClown - {-# INLINE fmap #-} - -instance Applicative f => Biapplicative (Clown f) where - bipure a _ = Clown (pure a) - {-# INLINE bipure #-} - - Clown mf <<*>> Clown mx = Clown (mf <*> mx) - {-# INLINE (<<*>>) #-} - -instance Foldable f => Bifoldable (Clown f) where - bifoldMap f _ = foldMap f . runClown - {-# INLINE bifoldMap #-} - -instance Foldable (Clown f a) where - foldMap _ = mempty - {-# INLINE foldMap #-} - -instance Traversable f => Bitraversable (Clown f) where - bitraverse f _ = fmap Clown . traverse f . runClown - {-# INLINE bitraverse #-} - -instance Traversable (Clown f a) where - traverse _ = pure . Clown . runClown - {-# INLINE traverse #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2016 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\"+-- by Conor McBride.+----------------------------------------------------------------------------+module Data.Bifunctor.Clown+ ( Clown(..)+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Data.Biapplicative+import Data.Bifoldable+import Data.Bitraversable+import Data.Functor.Classes++#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 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+ )++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data ClownMetaData+data ClownMetaCons+data ClownMetaSel++instance Datatype ClownMetaData where+ datatypeName _ = "Clown"+ moduleName _ = "Data.Bifunctor.Clown"++instance Constructor ClownMetaCons where+ conName _ = "Clown"+ conIsRecord _ = True++instance Selector ClownMetaSel where+ selName _ = "runClown"++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++#if LIFTED_FUNCTOR_CLASSES+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 (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 (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 (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)+#else+instance (Eq1 f, Eq a) => Eq1 (Clown f a) where+ eq1 = eqClown eq1++instance (Ord1 f, Ord a) => Ord1 (Clown f a) where+ compare1 = compareClown compare1++instance (Read1 f, Read a) => Read1 (Clown f a) where+ readsPrec1 = readsPrecClown readsPrec1++instance (Show1 f, Show a) => Show1 (Clown f a) where+ showsPrec1 = showsPrecClown showsPrec1+#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 #-}+ second _ = Clown . runClown+ {-# INLINE second #-}+ bimap f _ = Clown . fmap f . runClown+ {-# INLINE bimap #-}++instance Functor (Clown f a) where+ fmap _ = Clown . runClown+ {-# INLINE fmap #-}++instance Applicative f => Biapplicative (Clown f) where+ bipure a _ = Clown (pure a)+ {-# INLINE bipure #-}++ Clown mf <<*>> Clown mx = Clown (mf <*> mx)+ {-# INLINE (<<*>>) #-}++instance Foldable f => Bifoldable (Clown f) where+ bifoldMap f _ = foldMap f . runClown+ {-# INLINE bifoldMap #-}++instance Foldable (Clown f a) where+ foldMap _ = mempty+ {-# INLINE foldMap #-}++instance Traversable f => Bitraversable (Clown f) where+ bitraverse f _ = fmap Clown . traverse f . runClown+ {-# INLINE bitraverse #-}++instance Traversable (Clown f a) where+ traverse _ = pure . Clown . runClown+ {-# INLINE traverse #-}
src/Data/Bifunctor/Fix.hs view
@@ -1,120 +1,120 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# 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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- Module : Data.Bifunctor.Fix --- Copyright : (C) 2008-2016 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Data.Bifunctor.Fix - ( 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 GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 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) - -#if LIFTED_FUNCTOR_CLASSES -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 '}' -#endif - -instance Bifunctor p => Functor (Fix p) where - fmap f (In p) = In (bimap (fmap f) f p) - {-# INLINE fmap #-} - -instance Biapplicative p => Applicative (Fix p) where - pure a = In (bipure (pure a) a) - {-# INLINE pure #-} - In p <*> In q = In (biliftA2 (<*>) ($) p q) - {-# INLINE (<*>) #-} - -instance Bifoldable p => Foldable (Fix p) where - foldMap f (In p) = bifoldMap (foldMap f) f p - {-# INLINE foldMap #-} - -instance Bitraversable p => Traversable (Fix p) where - traverse f (In p) = In <$> bitraverse (traverse f) f p - {-# INLINE traverse #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- Module : Data.Bifunctor.Fix+-- Copyright : (C) 2008-2016 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Bifunctor.Fix+ ( 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 GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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 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)++#if LIFTED_FUNCTOR_CLASSES+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 '}'+#endif++instance Bifunctor p => Functor (Fix p) where+ fmap f (In p) = In (bimap (fmap f) f p)+ {-# INLINE fmap #-}++instance Biapplicative p => Applicative (Fix p) where+ pure a = In (bipure (pure a) a)+ {-# INLINE pure #-}+ In p <*> In q = In (biliftA2 (<*>) ($) p q)+ {-# INLINE (<*>) #-}++instance Bifoldable p => Foldable (Fix p) where+ foldMap f (In p) = bifoldMap (foldMap f) f p+ {-# INLINE foldMap #-}++instance Bitraversable p => Traversable (Fix p) where+ traverse f (In p) = In <$> bitraverse (traverse f) f p+ {-# INLINE traverse #-}
src/Data/Bifunctor/Flip.hs view
@@ -1,139 +1,139 @@-{-# 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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- Module : Data.Bifunctor.Flip --- 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.Flip - ( Flip(..) - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - -import Data.Biapplicative -import Data.Bifoldable -import Data.Bifunctor.Functor -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 GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 - ) - -#if LIFTED_FUNCTOR_CLASSES -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 '}' -#endif - -instance Bifunctor p => Bifunctor (Flip p) where - first f = Flip . second f . runFlip - {-# INLINE first #-} - second f = Flip . first f . runFlip - {-# INLINE second #-} - bimap f g = Flip . bimap g f . runFlip - {-# INLINE bimap #-} - -instance Bifunctor p => Functor (Flip p a) where - fmap f = Flip . first f . runFlip - {-# INLINE fmap #-} - -instance Biapplicative p => Biapplicative (Flip p) where - bipure a b = Flip (bipure b a) - {-# INLINE bipure #-} - - Flip fg <<*>> Flip xy = Flip (fg <<*>> xy) - {-# INLINE (<<*>>) #-} - -instance Bifoldable p => Bifoldable (Flip p) where - bifoldMap f g = bifoldMap g f . runFlip - {-# INLINE bifoldMap #-} - -instance Bifoldable p => Foldable (Flip p a) where - foldMap f = bifoldMap f (const mempty) . runFlip - {-# INLINE foldMap #-} - -instance Bitraversable p => Bitraversable (Flip p) where - bitraverse f g = fmap Flip . bitraverse g f . runFlip - {-# INLINE bitraverse #-} - -instance Bitraversable p => Traversable (Flip p a) where - traverse f = fmap Flip . bitraverse f pure . runFlip - {-# INLINE traverse #-} - -instance BifunctorFunctor Flip where - bifmap f (Flip p) = Flip (f p) +{-# 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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- Module : Data.Bifunctor.Flip+-- 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.Flip+ ( Flip(..)+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Data.Biapplicative+import Data.Bifoldable+import Data.Bifunctor.Functor+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 GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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+ )++#if LIFTED_FUNCTOR_CLASSES+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 '}'+#endif++instance Bifunctor p => Bifunctor (Flip p) where+ first f = Flip . second f . runFlip+ {-# INLINE first #-}+ second f = Flip . first f . runFlip+ {-# INLINE second #-}+ bimap f g = Flip . bimap g f . runFlip+ {-# INLINE bimap #-}++instance Bifunctor p => Functor (Flip p a) where+ fmap f = Flip . first f . runFlip+ {-# INLINE fmap #-}++instance Biapplicative p => Biapplicative (Flip p) where+ bipure a b = Flip (bipure b a)+ {-# INLINE bipure #-}++ Flip fg <<*>> Flip xy = Flip (fg <<*>> xy)+ {-# INLINE (<<*>>) #-}++instance Bifoldable p => Bifoldable (Flip p) where+ bifoldMap f g = bifoldMap g f . runFlip+ {-# INLINE bifoldMap #-}++instance Bifoldable p => Foldable (Flip p a) where+ foldMap f = bifoldMap f (const mempty) . runFlip+ {-# INLINE foldMap #-}++instance Bitraversable p => Bitraversable (Flip p) where+ bitraverse f g = fmap Flip . bitraverse g f . runFlip+ {-# INLINE bitraverse #-}++instance Bitraversable p => Traversable (Flip p a) where+ traverse f = fmap Flip . bitraverse f pure . runFlip+ {-# INLINE traverse #-}++instance BifunctorFunctor Flip where+ bifmap f (Flip p) = Flip (f p)
src/Data/Bifunctor/Functor.hs view
@@ -1,57 +1,57 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - -module Data.Bifunctor.Functor - ( (:->) - , BifunctorFunctor(..) - , BifunctorMonad(..) - , biliftM - , BifunctorComonad(..) - , biliftW - ) where - --- | Using parametricity as an approximation of a natural transformation in two arguments. -type (:->) p q = forall a b. p a b -> q a b -infixr 0 :-> - -class BifunctorFunctor t where - bifmap :: (p :-> q) -> t p :-> t q - -class BifunctorFunctor t => BifunctorMonad t where - bireturn :: p :-> t p - bibind :: (p :-> t q) -> t p :-> t q - 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) -{-# INLINE biliftM #-} - -class BifunctorFunctor t => BifunctorComonad t where - biextract :: t p :-> p - biextend :: (t p :-> q) -> t p :-> t q - 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) -{-# INLINE biliftW #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif++module Data.Bifunctor.Functor+ ( (:->)+ , BifunctorFunctor(..)+ , BifunctorMonad(..)+ , biliftM+ , BifunctorComonad(..)+ , biliftW+ ) where++-- | Using parametricity as an approximation of a natural transformation in two arguments.+type (:->) p q = forall a b. p a b -> q a b+infixr 0 :->++class BifunctorFunctor t where+ bifmap :: (p :-> q) -> t p :-> t q++class BifunctorFunctor t => BifunctorMonad t where+ bireturn :: p :-> t p+ bibind :: (p :-> t q) -> t p :-> t q+ 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)+{-# INLINE biliftM #-}++class BifunctorFunctor t => BifunctorComonad t where+ biextract :: t p :-> p+ biextend :: (t p :-> q) -> t p :-> t q+ 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)+{-# INLINE biliftW #-}
src/Data/Bifunctor/Join.hs view
@@ -1,123 +1,123 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# 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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2016 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Data.Bifunctor.Join - ( Join(..) - ) 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 GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 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) - -#if LIFTED_FUNCTOR_CLASSES -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 '}' -#endif - -instance Bifunctor p => Functor (Join p) where - fmap f (Join a) = Join (bimap f f a) - {-# INLINE fmap #-} - -instance Biapplicative p => Applicative (Join p) where - pure a = Join (bipure a a) - {-# INLINE pure #-} - Join f <*> Join a = Join (f <<*>> a) - {-# INLINE (<*>) #-} - Join a *> Join b = Join (a *>> b) - {-# INLINE (*>) #-} - Join a <* Join b = Join (a <<* b) - {-# INLINE (<*) #-} - -instance Bifoldable p => Foldable (Join p) where - foldMap f (Join a) = bifoldMap f f a - {-# INLINE foldMap #-} - -instance Bitraversable p => Traversable (Join p) where - traverse f (Join a) = fmap Join (bitraverse f f a) - {-# INLINE traverse #-} - sequenceA (Join a) = fmap Join (bisequenceA a) - {-# INLINE sequenceA #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2016 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+----------------------------------------------------------------------------+module Data.Bifunctor.Join+ ( Join(..)+ ) 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 GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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 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)++#if LIFTED_FUNCTOR_CLASSES+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 '}'+#endif++instance Bifunctor p => Functor (Join p) where+ fmap f (Join a) = Join (bimap f f a)+ {-# INLINE fmap #-}++instance Biapplicative p => Applicative (Join p) where+ pure a = Join (bipure a a)+ {-# INLINE pure #-}+ Join f <*> Join a = Join (f <<*>> a)+ {-# INLINE (<*>) #-}+ Join a *> Join b = Join (a *>> b)+ {-# INLINE (*>) #-}+ Join a <* Join b = Join (a <<* b)+ {-# INLINE (<*) #-}++instance Bifoldable p => Foldable (Join p) where+ foldMap f (Join a) = bifoldMap f f a+ {-# INLINE foldMap #-}++instance Bitraversable p => Traversable (Join p) where+ traverse f (Join a) = fmap Join (bitraverse f f a)+ {-# INLINE traverse #-}+ sequenceA (Join a) = fmap Join (bisequenceA a)+ {-# INLINE sequenceA #-}
src/Data/Bifunctor/Joker.hs view
@@ -1,191 +1,191 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2016 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" --- by Conor McBride. ----------------------------------------------------------------------------- -module Data.Bifunctor.Joker - ( Joker(..) - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - -import Data.Biapplicative -import Data.Bifoldable -import Data.Bitraversable -import Data.Functor.Classes - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 -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 - ) - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data JokerMetaData -data JokerMetaCons -data JokerMetaSel - -instance Datatype JokerMetaData where - datatypeName _ = "Joker" - moduleName _ = "Data.Bifunctor.Joker" - -instance Constructor JokerMetaCons where - conName _ = "Joker" - conIsRecord _ = True - -instance Selector JokerMetaSel where - selName _ = "runJoker" - -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 - -#if LIFTED_FUNCTOR_CLASSES -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 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 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 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) -#else -instance Eq1 g => Eq1 (Joker g a) where - eq1 = eqJoker eq1 - -instance Ord1 g => Ord1 (Joker g a) where - compare1 = compareJoker compare1 - -instance Read1 g => Read1 (Joker g a) where - readsPrec1 = readsPrecJoker readsPrec1 - -instance Show1 g => Show1 (Joker g a) where - showsPrec1 = showsPrecJoker showsPrec1 -#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 #-} - second g = Joker . fmap g . runJoker - {-# INLINE second #-} - bimap _ g = Joker . fmap g . runJoker - {-# INLINE bimap #-} - -instance Functor g => Functor (Joker g a) where - fmap g = Joker . fmap g . runJoker - {-# INLINE fmap #-} - -instance Applicative g => Biapplicative (Joker g) where - bipure _ b = Joker (pure b) - {-# INLINE bipure #-} - - Joker mf <<*>> Joker mx = Joker (mf <*> mx) - {-# INLINE (<<*>>) #-} - -instance Foldable g => Bifoldable (Joker g) where - bifoldMap _ g = foldMap g . runJoker - {-# INLINE bifoldMap #-} - -instance Foldable g => Foldable (Joker g a) where - foldMap g = foldMap g . runJoker - {-# INLINE foldMap #-} - -instance Traversable g => Bitraversable (Joker g) where - bitraverse _ g = fmap Joker . traverse g . runJoker - {-# INLINE bitraverse #-} - -instance Traversable g => Traversable (Joker g a) where - traverse g = fmap Joker . traverse g . runJoker - {-# INLINE traverse #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2016 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\"+-- by Conor McBride.+----------------------------------------------------------------------------+module Data.Bifunctor.Joker+ ( Joker(..)+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Data.Biapplicative+import Data.Bifoldable+import Data.Bitraversable+import Data.Functor.Classes++#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Data.Traversable+#endif++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ >= 702+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+ )++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data JokerMetaData+data JokerMetaCons+data JokerMetaSel++instance Datatype JokerMetaData where+ datatypeName _ = "Joker"+ moduleName _ = "Data.Bifunctor.Joker"++instance Constructor JokerMetaCons where+ conName _ = "Joker"+ conIsRecord _ = True++instance Selector JokerMetaSel where+ selName _ = "runJoker"++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++#if LIFTED_FUNCTOR_CLASSES+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 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 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 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)+#else+instance Eq1 g => Eq1 (Joker g a) where+ eq1 = eqJoker eq1++instance Ord1 g => Ord1 (Joker g a) where+ compare1 = compareJoker compare1++instance Read1 g => Read1 (Joker g a) where+ readsPrec1 = readsPrecJoker readsPrec1++instance Show1 g => Show1 (Joker g a) where+ showsPrec1 = showsPrecJoker showsPrec1+#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 #-}+ second g = Joker . fmap g . runJoker+ {-# INLINE second #-}+ bimap _ g = Joker . fmap g . runJoker+ {-# INLINE bimap #-}++instance Functor g => Functor (Joker g a) where+ fmap g = Joker . fmap g . runJoker+ {-# INLINE fmap #-}++instance Applicative g => Biapplicative (Joker g) where+ bipure _ b = Joker (pure b)+ {-# INLINE bipure #-}++ Joker mf <<*>> Joker mx = Joker (mf <*> mx)+ {-# INLINE (<<*>>) #-}++instance Foldable g => Bifoldable (Joker g) where+ bifoldMap _ g = foldMap g . runJoker+ {-# INLINE bifoldMap #-}++instance Foldable g => Foldable (Joker g a) where+ foldMap g = foldMap g . runJoker+ {-# INLINE foldMap #-}++instance Traversable g => Bitraversable (Joker g) where+ bitraverse _ g = fmap Joker . traverse g . runJoker+ {-# INLINE bitraverse #-}++instance Traversable g => Traversable (Joker g a) where+ traverse g = fmap Joker . traverse g . runJoker+ {-# INLINE traverse #-}
src/Data/Bifunctor/Product.hs view
@@ -1,187 +1,187 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -#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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2016 Jesse Selover, Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- The product of two bifunctors. ----------------------------------------------------------------------------- -module Data.Bifunctor.Product - ( Product(..) - ) where - -import qualified Control.Arrow as A -import Control.Category -import Data.Biapplicative -import Data.Bifoldable -import Data.Bifunctor.Functor -import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -import Data.Foldable -import Data.Monoid hiding (Product) -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 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 Datatype ProductMetaData where - datatypeName _ = "Product" - moduleName _ = "Data.Bifunctor.Product" - -instance Constructor ProductMetaCons where - conName _ = "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 - -#if LIFTED_FUNCTOR_CLASSES -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 (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 (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 (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 -#endif - -instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where - first f (Pair x y) = Pair (first f x) (first f y) - {-# INLINE first #-} - second g (Pair x y) = Pair (second g x) (second g y) - {-# INLINE second #-} - bimap f g (Pair x y) = Pair (bimap f g x) (bimap f g y) - {-# INLINE bimap #-} - -instance (Biapplicative f, Biapplicative g) => Biapplicative (Product f g) where - bipure a b = Pair (bipure a b) (bipure a b) - {-# INLINE bipure #-} - Pair w x <<*>> Pair y z = Pair (w <<*>> y) (x <<*>> z) - {-# INLINE (<<*>>) #-} - -instance (Bifoldable f, Bifoldable g) => Bifoldable (Product f g) where - bifoldMap f g (Pair x y) = bifoldMap f g x `mappend` bifoldMap f g y - {-# INLINE bifoldMap #-} - -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 #-} - -instance BifunctorFunctor (Product p) where - bifmap f (Pair p q) = Pair p (f q) - -instance BifunctorComonad (Product p) where - 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') +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++#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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2016 Jesse Selover, Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- The product of two bifunctors.+----------------------------------------------------------------------------+module Data.Bifunctor.Product+ ( Product(..)+ ) where++import qualified Control.Arrow as A+import Control.Category+import Data.Biapplicative+import Data.Bifoldable+import Data.Bifunctor.Functor+import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+import Data.Foldable+import Data.Monoid hiding (Product)+import Data.Traversable+#endif++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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 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 Datatype ProductMetaData where+ datatypeName _ = "Product"+ moduleName _ = "Data.Bifunctor.Product"++instance Constructor ProductMetaCons where+ conName _ = "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++#if LIFTED_FUNCTOR_CLASSES+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 (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 (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 (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+#endif++instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where+ first f (Pair x y) = Pair (first f x) (first f y)+ {-# INLINE first #-}+ second g (Pair x y) = Pair (second g x) (second g y)+ {-# INLINE second #-}+ bimap f g (Pair x y) = Pair (bimap f g x) (bimap f g y)+ {-# INLINE bimap #-}++instance (Biapplicative f, Biapplicative g) => Biapplicative (Product f g) where+ bipure a b = Pair (bipure a b) (bipure a b)+ {-# INLINE bipure #-}+ Pair w x <<*>> Pair y z = Pair (w <<*>> y) (x <<*>> z)+ {-# INLINE (<<*>>) #-}++instance (Bifoldable f, Bifoldable g) => Bifoldable (Product f g) where+ bifoldMap f g (Pair x y) = bifoldMap f g x `mappend` bifoldMap f g y+ {-# INLINE bifoldMap #-}++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 #-}++instance BifunctorFunctor (Product p) where+ bifmap f (Pair p q) = Pair p (f q)++instance BifunctorComonad (Product p) where+ 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')
src/Data/Bifunctor/Sum.hs view
@@ -1,146 +1,146 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -#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 -#include "bifunctors-common.h" - -module Data.Bifunctor.Sum where - -import Data.Bifunctor -import Data.Bifunctor.Functor -import Data.Bifoldable -import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Functor -import Data.Monoid hiding (Sum) -import Data.Traversable -#endif -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 - ) -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) - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data SumMetaData -data SumMetaConsL2 -data SumMetaConsR2 - -instance Datatype SumMetaData where - datatypeName _ = "Sum" - moduleName _ = "Data.Bifunctor.Sum" - -instance Constructor SumMetaConsL2 where - conName _ = "L2" - -instance Constructor SumMetaConsR2 where - conName _ = "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 - -#if LIFTED_FUNCTOR_CLASSES -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 (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 (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 (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 -#endif - -instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where - bimap f g (L2 p) = L2 (bimap f g p) - bimap f g (R2 q) = R2 (bimap f g q) - first f (L2 p) = L2 (first f p) - first f (R2 q) = R2 (first f q) - second f (L2 p) = L2 (second f p) - second f (R2 q) = R2 (second f q) - -instance (Bifoldable p, Bifoldable q) => Bifoldable (Sum p q) where - bifoldMap f g (L2 p) = bifoldMap f g p - bifoldMap f g (R2 q) = bifoldMap f g q - -instance (Bitraversable p, Bitraversable q) => Bitraversable (Sum p q) where - bitraverse f g (L2 p) = L2 <$> bitraverse f g p - bitraverse f g (R2 q) = R2 <$> bitraverse f g q - -instance BifunctorFunctor (Sum p) where - bifmap _ (L2 p) = L2 p - bifmap f (R2 q) = R2 (f q) - -instance BifunctorMonad (Sum p) where - bireturn = R2 - bijoin (L2 p) = L2 p - bijoin (R2 q) = q - bibind _ (L2 p) = L2 p - bibind f (R2 q) = f q +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++#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+#include "bifunctors-common.h"++module Data.Bifunctor.Sum where++import Data.Bifunctor+import Data.Bifunctor.Functor+import Data.Bifoldable+import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Data.Functor+import Data.Monoid hiding (Sum)+import Data.Traversable+#endif+#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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+ )+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)++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data SumMetaData+data SumMetaConsL2+data SumMetaConsR2++instance Datatype SumMetaData where+ datatypeName _ = "Sum"+ moduleName _ = "Data.Bifunctor.Sum"++instance Constructor SumMetaConsL2 where+ conName _ = "L2"++instance Constructor SumMetaConsR2 where+ conName _ = "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++#if LIFTED_FUNCTOR_CLASSES+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 (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 (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 (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+#endif++instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where+ bimap f g (L2 p) = L2 (bimap f g p)+ bimap f g (R2 q) = R2 (bimap f g q)+ first f (L2 p) = L2 (first f p)+ first f (R2 q) = R2 (first f q)+ second f (L2 p) = L2 (second f p)+ second f (R2 q) = R2 (second f q)++instance (Bifoldable p, Bifoldable q) => Bifoldable (Sum p q) where+ bifoldMap f g (L2 p) = bifoldMap f g p+ bifoldMap f g (R2 q) = bifoldMap f g q++instance (Bitraversable p, Bitraversable q) => Bitraversable (Sum p q) where+ bitraverse f g (L2 p) = L2 <$> bitraverse f g p+ bitraverse f g (R2 q) = R2 <$> bitraverse f g q++instance BifunctorFunctor (Sum p) where+ bifmap _ (L2 p) = L2 p+ bifmap f (R2 q) = R2 (f q)++instance BifunctorMonad (Sum p) where+ bireturn = R2+ bijoin (L2 p) = L2 p+ bijoin (R2 q) = q+ bibind _ (L2 p) = L2 p+ bibind f (R2 q) = f q
src/Data/Bifunctor/TH.hs view
@@ -1,1334 +1,1344 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -#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 - , 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 -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. - -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only - -- available in 7.8 or later.) - } deriving (Eq, Ord, Read, Show) - --- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to --- prevent users from having to enable that extension at use sites.) -defaultOptions :: Options -defaultOptions = Options { emptyCaseBehavior = False } - -{- $derive - -'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically -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 -#if MIN_VERSION_template_haskell(2,9,0) - roles <- reifyRoles _parentName -#endif - case () of - _ - -#if MIN_VERSION_template_haskell(2,9,0) - | Just (rs, PhantomR) <- unsnoc roles - , Just (_, PhantomR) <- unsnoc rs - -> biFunPhantom z value -#endif - - | null cons && emptyCaseBehavior opts && ghc7'8OrLater - -> biFunEmptyCase biFun z value - - | null cons - -> biFunNoCons biFun z value - - | otherwise - -> caseE (varE value) - (map (makeBiFunForCon biFun z tvMap) cons) - - ghc7'8OrLater :: Bool -#if __GLASGOW_HASKELL__ >= 708 - ghc7'8OrLater = True -#else - ghc7'8OrLater = False -#endif - -#if MIN_VERSION_template_haskell(2,9,0) - biFunPhantom :: Name -> Name -> Q Exp - biFunPhantom z value = - biFunTrivial coerce - (varE pureValName `appE` coerce) - biFun z - where - coerce :: Q Exp - coerce = varE coerceValName `appE` varE value -#endif - --- | Generates a 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 :: Bool - isDataFamily = case variant of - Datatype -> False - Newtype -> False - DataInstance -> True - NewtypeInstance -> True - - remainingTysOrigSubst' :: [Type] - -- See Note [Kind signatures in derived instances] for an explanation - -- of the isDataFamily check. - 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 appeard 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 - -------------------------------------------------------------------------------- --- 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 -#if MIN_VERSION_template_haskell(2,6,0) - | UnboxedTupleT len <- f - -> tuple $ Unboxed len -#endif - | fc || or (take numFirstArgs xcs) - -> wrongArg -- T (..var..) ty_1 ... ty_n - | otherwise -- T (..no var..) ty_1 ... ty_n - -> do itf <- isInTypeFamilyApp tyVarNames f args - if itf -- We can't decompose type families, so - -- error if we encounter one here. - then wrongArg - else return ( caseTyApp $ drop numFirstArgs $ zip args xrs - , True ) - go co (SigT t k) = do - (_, kc) <- go_kind co k - if kc - then return (caseWrongArg, True) - else go co t - go co (VarT v) - | Map.member v tvMap - = return (if co then caseCoVar v else caseVar v, True) - | otherwise - = trivial - go co (ForallT tvbs _ t) = do - (tr, tc) <- go co t - let tvbNames = map tvName tvbs - if not tc || any (`elem` tvbNames) tyVarNames - then trivial - else return (caseForAll tvbs tr, True) - go _ _ = trivial - - go_kind :: Bool - -> Kind - -> Q (a, Bool) -#if MIN_VERSION_template_haskell(2,9,0) - go_kind = go -#else - go_kind _ _ = trivial -#endif - - trivial :: Q (a, Bool) - trivial = return (caseTrivial, False) - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - --- Fold over the arguments of a data constructor in a Functor-like way. -foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a] -foldDataConArgs tvMap ft con = do - fieldTys <- mapM resolveTypeSynonyms $ constructorFields con - mapM foldArg fieldTys - where - foldArg :: Type -> Q a - foldArg = functorLikeTraverse tvMap ft - --- Make a 'LamE' using a fresh variable. -mkSimpleLam :: (Exp -> Q Exp) -> Q Exp -mkSimpleLam lam = do - -- 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" - body <- lam (VarE n) - return $ LamE [VarP n] body - --- Make a 'LamE' using two fresh variables. -mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp -mkSimpleLam2 lam = do - -- 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" - body <- lam (VarE n1) (VarE n2) - return $ LamE [VarP n1, VarP n2] body - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConMatch fold conName insides@ produces a match clause in --- which the LHS pattern-matches on @extraPats@, followed by a match on the --- constructor @conName@ and its arguments. The RHS folds (with @fold@) over --- @conName@ and its arguments, applying an expression (from @insides@) to each --- of the respective arguments of @conName@. -mkSimpleConMatch :: (Name -> [a] -> Q Exp) - -> Name - -> [Exp -> a] - -> Q Match -mkSimpleConMatch fold conName insides = do - varsNeeded <- newNameList "_arg" $ length insides - let pat = 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 - -- indicies in each expression to match up with the argument indices - -- in conExpr (defined below). - exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) - else Nothing) - insides varsNeeded - -- An element of argTysTyVarInfo is True if the constructor argument - -- with the same index has a type which mentions the last type - -- variable. - argTysTyVarInfo = map (\(m, _) -> m) insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded - - conExpQ - | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) - | otherwise = do - bs <- newNameList "b" lengthInsides - let bs' = filterByList argTysTyVarInfo bs - vars = filterByLists argTysTyVarInfo - (map varE bs) (map varE varsNeeded) - lamE (map varP bs') (appsE (conE conName:vars)) - - conExp <- conExpQ - rhs <- fold conExp exps - return $ Match pat (NormalB rhs) [] - where - lengthInsides = length insides - --- Indicates whether a tuple is boxed or unboxed, as well as its number of --- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) --- corresponds to @Unboxed 3@. -data TupleSort - = Boxed Int -#if MIN_VERSION_template_haskell(2,6,0) - | Unboxed Int -#endif - --- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: (Name -> [a] -> Q Match) - -> TupleSort -> [a] -> Exp -> Q Exp -mkSimpleTupleCase matchForCon tupSort insides x = do - let tupDataName = case tupSort of - Boxed len -> tupleDataName len -#if MIN_VERSION_template_haskell(2,6,0) - Unboxed len -> unboxedTupleDataName len -#endif - m <- matchForCon tupDataName insides - return $ CaseE x [m] - --- 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 +{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++#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+ , 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.+ -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only+ -- available in 7.8 or later.)+ } deriving (Eq, Ord, Read, Show)++-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to+-- prevent users from having to enable that extension at use sites.)+defaultOptions :: Options+defaultOptions = Options { emptyCaseBehavior = False }++{- $derive++'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically+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+#if MIN_VERSION_template_haskell(2,9,0)+ roles <- reifyRoles _parentName+#endif+ case () of+ _++#if MIN_VERSION_template_haskell(2,9,0)+ | Just (rs, PhantomR) <- unsnoc roles+ , Just (_, PhantomR) <- unsnoc rs+ -> biFunPhantom z value+#endif++ | null cons && emptyCaseBehavior opts && ghc7'8OrLater+ -> biFunEmptyCase biFun z value++ | null cons+ -> biFunNoCons biFun z value++ | otherwise+ -> caseE (varE value)+ (map (makeBiFunForCon biFun z tvMap) cons)++ ghc7'8OrLater :: Bool+#if __GLASGOW_HASKELL__ >= 708+ ghc7'8OrLater = True+#else+ ghc7'8OrLater = False+#endif++#if MIN_VERSION_template_haskell(2,9,0)+ biFunPhantom :: Name -> Name -> Q Exp+ biFunPhantom z value =+ biFunTrivial coerce+ (varE pureValName `appE` coerce)+ biFun z+ where+ coerce :: Q Exp+ coerce = varE coerceValName `appE` varE value+#endif++-- | Generates a 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 appeard 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+#if MIN_VERSION_template_haskell(2,6,0)+ | UnboxedTupleT len <- f+ -> tuple $ Unboxed len+#endif+ | fc || or (take numFirstArgs xcs)+ -> wrongArg -- T (..var..) ty_1 ... ty_n+ | otherwise -- T (..no var..) ty_1 ... ty_n+ -> do itf <- isInTypeFamilyApp tyVarNames f args+ if itf -- We can't decompose type families, so+ -- error if we encounter one here.+ then wrongArg+ else return ( caseTyApp $ drop numFirstArgs $ zip args xrs+ , True )+ go co (SigT t k) = do+ (_, kc) <- go_kind co k+ if kc+ then return (caseWrongArg, True)+ else go co t+ go co (VarT v)+ | Map.member v tvMap+ = return (if co then caseCoVar v else caseVar v, True)+ | otherwise+ = trivial+ go co (ForallT tvbs _ t) = do+ (tr, tc) <- go co t+ let tvbNames = map tvName tvbs+ if not tc || any (`elem` tvbNames) tyVarNames+ then trivial+ else return (caseForAll tvbs tr, True)+ go _ _ = trivial++ go_kind :: Bool+ -> Kind+ -> Q (a, Bool)+#if MIN_VERSION_template_haskell(2,9,0)+ go_kind = go+#else+ go_kind _ _ = trivial+#endif++ trivial :: Q (a, Bool)+ trivial = return (caseTrivial, False)++ tyVarNames :: [Name]+ tyVarNames = Map.keys tvMap++-- Fold over the arguments of a data constructor in a Functor-like way.+foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]+foldDataConArgs tvMap ft con = do+ fieldTys <- mapM resolveTypeSynonyms $ constructorFields con+ mapM foldArg fieldTys+ where+ foldArg :: Type -> Q a+ foldArg = functorLikeTraverse tvMap ft++-- Make a 'LamE' using a fresh variable.+mkSimpleLam :: (Exp -> Q Exp) -> Q Exp+mkSimpleLam lam = do+ -- 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"+ body <- lam (VarE n)+ return $ LamE [VarP n] body++-- Make a 'LamE' using two fresh variables.+mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp+mkSimpleLam2 lam = do+ -- 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"+ body <- lam (VarE n1) (VarE n2)+ return $ LamE [VarP n1, VarP n2] body++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConMatch fold conName insides@ produces a match clause in+-- which the LHS pattern-matches on @extraPats@, followed by a match on the+-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over+-- @conName@ and its arguments, applying an expression (from @insides@) to each+-- of the respective arguments of @conName@.+mkSimpleConMatch :: (Name -> [a] -> Q Exp)+ -> Name+ -> [Exp -> a]+ -> Q Match+mkSimpleConMatch fold conName insides = do+ varsNeeded <- newNameList "_arg" $ length insides+ let pat = 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+ -- indicies in each expression to match up with the argument indices+ -- in conExpr (defined below).+ exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v)+ else Nothing)+ insides varsNeeded+ -- An element of argTysTyVarInfo is True if the constructor argument+ -- with the same index has a type which mentions the last type+ -- variable.+ argTysTyVarInfo = map (\(m, _) -> m) insides+ (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded++ conExpQ+ | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar)+ | otherwise = do+ bs <- newNameList "b" lengthInsides+ let bs' = filterByList argTysTyVarInfo bs+ vars = filterByLists argTysTyVarInfo+ (map varE bs) (map varE varsNeeded)+ lamE (map varP bs') (appsE (conE conName:vars))++ conExp <- conExpQ+ rhs <- fold conExp exps+ return $ Match pat (NormalB rhs) []+ where+ lengthInsides = length insides++-- Indicates whether a tuple is boxed or unboxed, as well as its number of+-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)+-- corresponds to @Unboxed 3@.+data TupleSort+ = Boxed Int+#if MIN_VERSION_template_haskell(2,6,0)+ | Unboxed Int+#endif++-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"+mkSimpleTupleCase :: (Name -> [a] -> Q Match)+ -> TupleSort -> [a] -> Exp -> Q Exp+mkSimpleTupleCase matchForCon tupSort insides x = do+ let tupDataName = case tupSort of+ Boxed len -> tupleDataName len+#if MIN_VERSION_template_haskell(2,6,0)+ Unboxed len -> unboxedTupleDataName len+#endif+ m <- matchForCon tupDataName insides+ return $ CaseE x [m]++-- 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,574 +1,574 @@-{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Unsafe #-} -#endif - -{-| -Module: Data.Bifunctor.TH.Internal -Copyright: (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Edward Kmett -Portability: Template Haskell - -Template Haskell-related utilities. --} -module Data.Bifunctor.TH.Internal where - -import Data.Foldable (foldr') -import qualified Data.List as List -import qualified Data.Map as Map (singleton) -import Data.Map (Map) -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Set as Set -import Data.Set (Set) - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- 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 -------------------------------------------------------------------------------- - -applySubstitutionKind :: Map Name Kind -> Type -> Type -#if MIN_VERSION_template_haskell(2,8,0) -applySubstitutionKind = applySubstitution -#else -applySubstitutionKind _ t = t -#endif - -substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = applySubstitutionKind (Map.singleton n k) - -substNamesWithKindStar :: [Name] -> Type -> Type -substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns - -------------------------------------------------------------------------------- --- Type-specialized const functions -------------------------------------------------------------------------------- - -bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d -bimapConst = const . const . const -{-# INLINE bimapConst #-} - -bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c -bifoldrConst = const . const . const . const -{-# INLINE bifoldrConst #-} - -bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m -bifoldMapConst = const . const . const -{-# INLINE bifoldMapConst #-} - -bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d) -bitraverseConst = const . const . const -{-# INLINE bitraverseConst #-} - -------------------------------------------------------------------------------- --- StarKindStatus -------------------------------------------------------------------------------- - --- | Whether a type is not of kind *, is of kind *, or is a kind variable. -data StarKindStatus = NotKindStar - | KindStar - | IsKindVar Name - deriving Eq - --- | Does a Type have kind * or k (for some kind variable k)? -canRealizeKindStar :: Type -> StarKindStatus -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. --- Otherwise, returns 'Nothing'. -starKindStatusToName :: StarKindStatus -> Maybe Name -starKindStatusToName (IsKindVar n) = Just n -starKindStatusToName _ = Nothing - --- | Concat together all of the StarKindStatuses that are IsKindVar and extract --- the kind variables' Names out. -catKindVarNames :: [StarKindStatus] -> [Name] -catKindVarNames = mapMaybe starKindStatusToName - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - --- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) - --- | 'filterByList' takes a list of Bools and a list of some elements and --- filters out these elements for which the corresponding value in the list of --- Bools is False. This function does not check whether the lists have equal --- length. -filterByList :: [Bool] -> [a] -> [a] -filterByList (True:bs) (x:xs) = x : filterByList bs xs -filterByList (False:bs) (_:xs) = filterByList bs xs -filterByList _ _ = [] - --- | 'filterByLists' takes a list of Bools and two lists as input, and --- outputs a new list consisting of elements from the last two input lists. For --- each Bool in the list, if it is 'True', then it takes an element from the --- former list. If it is 'False', it takes an element from the latter list. --- The elements taken correspond to the index of the Bool in its list. --- For example: --- --- @ --- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" --- @ --- --- This function does not check whether the lists have equal length. -filterByLists :: [Bool] -> [a] -> [a] -> [a] -filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys -filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys -filterByLists _ _ _ = [] - --- | 'partitionByList' takes a list of Bools and a list of some elements and --- partitions the list according to the list of Bools. Elements corresponding --- to 'True' go to the left; elements corresponding to 'False' go to the right. --- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ --- This function does not check whether the lists have equal --- length. -partitionByList :: [Bool] -> [a] -> ([a], [a]) -partitionByList = go [] [] - where - go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs - go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs - go trues falses _ _ = (reverse trues, reverse falses) - --- | 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 - --- | @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. -hasKindVarChain :: Int -> Type -> Maybe [Name] -hasKindVarChain kindArrows t = - let uk = uncurryKind (tyKind t) - in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (freeVariables uk) - else Nothing - --- | If a Type is a SigT, returns its kind signature. Otherwise, return *. -tyKind :: Type -> Kind -tyKind (SigT _ k) = k -tyKind _ = starK - --- | 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 --- functions which map their respective type variables. -type TyVarMap = Map Name Name - -thd3 :: (a, b, c) -> c -thd3 (_, _, c) = c - -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] - --- | 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: --- --- (1) All of the dropped types are type variables --- (2) All of the dropped types are distinct --- (3) None of the remaining types mention any of the dropped types -canEtaReduce :: [Type] -> [Type] -> Bool -canEtaReduce remaining dropped = - all isTyVar dropped - && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type - -- didn't have an Ord instance until template-haskell-2.10.0.0 - && not (any (`mentionsName` droppedNames) remaining) - where - droppedNames :: [Name] - droppedNames = map varTToName dropped - --- | Extract Just the Name from a type variable. If the argument Type is not a --- type variable, return Nothing. -varTToName_maybe :: Type -> Maybe Name -varTToName_maybe (VarT n) = Just n -varTToName_maybe (SigT t _) = varTToName_maybe t -varTToName_maybe _ = Nothing - --- | Extract the Name from a type variable. If the argument Type is not a --- type variable, throw an error. -varTToName :: Type -> Name -varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe - --- | Peel off a kind signature from a Type (if it has one). -unSigT :: Type -> Type -unSigT (SigT t _) = t -unSigT t = t - --- | Is the given type a variable? -isTyVar :: Type -> Bool -isTyVar (VarT _) = True -isTyVar (SigT t _) = isTyVar t -isTyVar _ = 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 -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ - -> withinFirstArgs bndrs -#elif MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD TypeFam _ bndrs _) _ - -> withinFirstArgs bndrs -#else - TyConI (FamilyD TypeFam _ bndrs _) - -> withinFirstArgs bndrs -#endif - -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ - -> withinFirstArgs bndrs -#elif MIN_VERSION_template_haskell(2,9,0) - FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ - -> withinFirstArgs bndrs -#endif - - _ -> return False - where - withinFirstArgs :: [a] -> Q Bool - withinFirstArgs bndrs = - let firstArgs = take (length bndrs) tyArgs - argFVs = freeVariables firstArgs - in return $ any (`elem` argFVs) names - --- | Are all of the items in a list (which have an ordering) distinct? --- --- This uses Set (as opposed to nub) for better asymptotic time complexity. -allDistinct :: Ord a => [a] -> Bool -allDistinct = allDistinct' Set.empty - where - allDistinct' :: Ord a => Set a -> [a] -> Bool - allDistinct' uniqs (x:xs) - | x `Set.member` uniqs = False - | otherwise = allDistinct' (Set.insert x uniqs) xs - allDistinct' _ _ = True - --- | Does the given type mention any of the Names in the list? -mentionsName :: Type -> [Name] -> Bool -mentionsName = go - 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 (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 = List.foldl' AppT - --- | Fully applies a type constructor to its type variables. -applyTyCon :: Name -> [Type] -> Type -applyTyCon = applyTy . ConT - --- | Split an applied type into its individual components. For example, this: --- --- @ --- Either Int Char --- @ --- --- would split to this: --- --- @ --- [Either, Int, Char] --- @ -unapplyTy :: Type -> (Type, [Type]) -unapplyTy ty = go ty ty [] - where - go :: Type -> Type -> [Type] -> (Type, [Type]) - go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) - go origTy (SigT ty' _) args = go origTy ty' args -#if MIN_VERSION_template_haskell(2,11,0) - go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args - go origTy (ParensT ty') args = go origTy ty' args -#endif - go origTy _ args = (origTy, args) - --- | Split a type signature by the arrows on its spine. For example, this: --- --- @ --- forall a b. (a ~ b) => (a -> b) -> Char -> () --- @ --- --- would split to this: --- --- @ --- (a ~ b, [a -> b, Char, ()]) --- @ -uncurryTy :: Type -> (Cxt, [Type]) -uncurryTy (AppT (AppT ArrowT t1) t2) = - let (ctxt, tys) = uncurryTy t2 - in (ctxt, t1:tys) -uncurryTy (SigT t _) = uncurryTy t -uncurryTy (ForallT _ ctxt t) = - let (ctxt', tys) = uncurryTy t - in (ctxt ++ ctxt', tys) -uncurryTy t = ([], [t]) - --- | 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 -------------------------------------------------------------------------------- - --- 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" - -bifoldrConstValName :: Name -bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst" - -bifoldMapConstValName :: Name -bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst" - -coerceValName :: Name -coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" - -bitraverseConstValName :: Name -bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" - -wrapMonadDataName :: Name -wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" - -functorTypeName :: Name -functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" - -foldableTypeName :: Name -foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" - -traversableTypeName :: Name -traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" - -composeValName :: Name -composeValName = mkNameG_v "base" "GHC.Base" "." - -idValName :: Name -idValName = mkNameG_v "base" "GHC.Base" "id" - -errorValName :: Name -errorValName = mkNameG_v "base" "GHC.Err" "error" - -flipValName :: Name -flipValName = mkNameG_v "base" "GHC.Base" "flip" - -fmapValName :: Name -fmapValName = mkNameG_v "base" "GHC.Base" "fmap" - -foldrValName :: Name -foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" - -foldMapValName :: Name -foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" - -seqValName :: Name -seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" - -traverseValName :: Name -traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" - -unwrapMonadValName :: Name -unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "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" - -bimapValName :: Name -bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap" - -pureValName :: Name -pureValName = mkNameG_v "base" "Control.Applicative" "pure" - -apValName :: Name -apValName = mkNameG_v "base" "Control.Applicative" "<*>" - -liftA2ValName :: Name -liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" - -mappendValName :: Name -mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" - -memptyValName :: Name -memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" -#endif - -#if MIN_VERSION_base(4,10,0) -bifoldableTypeName :: Name -bifoldableTypeName = mkNameG_tc "base" "Data.Bifoldable" "Bifoldable" - -bitraversableTypeName :: Name -bitraversableTypeName = mkNameG_tc "base" "Data.Bitraversable" "Bitraversable" - -bifoldrValName :: Name -bifoldrValName = mkNameG_v "base" "Data.Bifoldable" "bifoldr" - -bifoldMapValName :: Name -bifoldMapValName = mkNameG_v "base" "Data.Bifoldable" "bifoldMap" - -bitraverseValName :: Name -bitraverseValName = mkNameG_v "base" "Data.Bitraversable" "bitraverse" -#else -bifoldableTypeName :: Name -bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable" - -bitraversableTypeName :: Name -bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable" - -bifoldrValName :: Name -bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr" - -bifoldMapValName :: Name -bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap" - -bitraverseValName :: Name -bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse" -#endif - -#if MIN_VERSION_base(4,11,0) -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" - -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" - -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" - -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" -#else -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" - -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" - -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" - -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" -#endif +{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Unsafe #-}+#endif++{-|+Module: Data.Bifunctor.TH.Internal+Copyright: (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Edward Kmett+Portability: Template Haskell++Template Haskell-related utilities.+-}+module Data.Bifunctor.TH.Internal where++import Data.Foldable (foldr')+import qualified Data.List as List+import qualified Data.Map as Map (singleton)+import Data.Map (Map)+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Set as Set+import Data.Set (Set)++import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-- 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+-------------------------------------------------------------------------------++applySubstitutionKind :: Map Name Kind -> Type -> Type+#if MIN_VERSION_template_haskell(2,8,0)+applySubstitutionKind = applySubstitution+#else+applySubstitutionKind _ t = t+#endif++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = applySubstitutionKind (Map.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns++-------------------------------------------------------------------------------+-- Type-specialized const functions+-------------------------------------------------------------------------------++bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d+bimapConst = const . const . const+{-# INLINE bimapConst #-}++bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c+bifoldrConst = const . const . const . const+{-# INLINE bifoldrConst #-}++bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m+bifoldMapConst = const . const . const+{-# INLINE bifoldMapConst #-}++bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d)+bitraverseConst = const . const . const+{-# INLINE bitraverseConst #-}++-------------------------------------------------------------------------------+-- StarKindStatus+-------------------------------------------------------------------------------++-- | Whether a type is not of kind *, is of kind *, or is a kind variable.+data StarKindStatus = NotKindStar+ | KindStar+ | IsKindVar Name+ deriving Eq++-- | Does a Type have kind * or k (for some kind variable k)?+canRealizeKindStar :: Type -> StarKindStatus+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.+-- Otherwise, returns 'Nothing'.+starKindStatusToName :: StarKindStatus -> Maybe Name+starKindStatusToName (IsKindVar n) = Just n+starKindStatusToName _ = Nothing++-- | Concat together all of the StarKindStatuses that are IsKindVar and extract+-- the kind variables' Names out.+catKindVarNames :: [StarKindStatus] -> [Name]+catKindVarNames = mapMaybe starKindStatusToName++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed)++-- | 'filterByList' takes a list of Bools and a list of some elements and+-- filters out these elements for which the corresponding value in the list of+-- Bools is False. This function does not check whether the lists have equal+-- length.+filterByList :: [Bool] -> [a] -> [a]+filterByList (True:bs) (x:xs) = x : filterByList bs xs+filterByList (False:bs) (_:xs) = filterByList bs xs+filterByList _ _ = []++-- | 'filterByLists' takes a list of Bools and two lists as input, and+-- outputs a new list consisting of elements from the last two input lists. For+-- each Bool in the list, if it is 'True', then it takes an element from the+-- former list. If it is 'False', it takes an element from the latter list.+-- The elements taken correspond to the index of the Bool in its list.+-- For example:+--+-- @+-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"+-- @+--+-- This function does not check whether the lists have equal length.+filterByLists :: [Bool] -> [a] -> [a] -> [a]+filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys+filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys+filterByLists _ _ _ = []++-- | 'partitionByList' takes a list of Bools and a list of some elements and+-- partitions the list according to the list of Bools. Elements corresponding+-- to 'True' go to the left; elements corresponding to 'False' go to the right.+-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@+-- This function does not check whether the lists have equal+-- length.+partitionByList :: [Bool] -> [a] -> ([a], [a])+partitionByList = go [] []+ where+ go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs+ go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs+ go trues falses _ _ = (reverse trues, reverse falses)++-- | 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++-- | @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.+hasKindVarChain :: Int -> Type -> Maybe [Name]+hasKindVarChain kindArrows t =+ let uk = uncurryKind (tyKind t)+ in if (length uk - 1 == kindArrows) && all isStarOrVar uk+ then Just (freeVariables uk)+ else Nothing++-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.+tyKind :: Type -> Kind+tyKind (SigT _ k) = k+tyKind _ = starK++-- | 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+-- functions which map their respective type variables.+type TyVarMap = Map Name Name++thd3 :: (a, b, c) -> c+thd3 (_, _, c) = c++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]++-- | 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:+--+-- (1) All of the dropped types are type variables+-- (2) All of the dropped types are distinct+-- (3) None of the remaining types mention any of the dropped types+canEtaReduce :: [Type] -> [Type] -> Bool+canEtaReduce remaining dropped =+ all isTyVar dropped+ && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type+ -- didn't have an Ord instance until template-haskell-2.10.0.0+ && not (any (`mentionsName` droppedNames) remaining)+ where+ droppedNames :: [Name]+ droppedNames = map varTToName dropped++-- | Extract Just the Name from a type variable. If the argument Type is not a+-- type variable, return Nothing.+varTToName_maybe :: Type -> Maybe Name+varTToName_maybe (VarT n) = Just n+varTToName_maybe (SigT t _) = varTToName_maybe t+varTToName_maybe _ = Nothing++-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error.+varTToName :: Type -> Name+varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe++-- | Peel off a kind signature from a Type (if it has one).+unSigT :: Type -> Type+unSigT (SigT t _) = t+unSigT t = t++-- | Is the given type a variable?+isTyVar :: Type -> Bool+isTyVar (VarT _) = True+isTyVar (SigT t _) = isTyVar t+isTyVar _ = 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+#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> withinFirstArgs bndrs+#elif MIN_VERSION_template_haskell(2,7,0)+ FamilyI (FamilyD TypeFam _ bndrs _) _+ -> withinFirstArgs bndrs+#else+ TyConI (FamilyD TypeFam _ bndrs _)+ -> withinFirstArgs bndrs+#endif++#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> withinFirstArgs bndrs+#elif MIN_VERSION_template_haskell(2,9,0)+ FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+ -> withinFirstArgs bndrs+#endif++ _ -> return False+ where+ withinFirstArgs :: [a] -> Q Bool+ withinFirstArgs bndrs =+ let firstArgs = take (length bndrs) tyArgs+ argFVs = freeVariables firstArgs+ in return $ any (`elem` argFVs) names++-- | Are all of the items in a list (which have an ordering) distinct?+--+-- This uses Set (as opposed to nub) for better asymptotic time complexity.+allDistinct :: Ord a => [a] -> Bool+allDistinct = allDistinct' Set.empty+ where+ allDistinct' :: Ord a => Set a -> [a] -> Bool+ allDistinct' uniqs (x:xs)+ | x `Set.member` uniqs = False+ | otherwise = allDistinct' (Set.insert x uniqs) xs+ allDistinct' _ _ = True++-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go+ 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 (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 = List.foldl' AppT++-- | Fully applies a type constructor to its type variables.+applyTyCon :: Name -> [Type] -> Type+applyTyCon = applyTy . ConT++-- | Split an applied type into its individual components. For example, this:+--+-- @+-- Either Int Char+-- @+--+-- would split to this:+--+-- @+-- [Either, Int, Char]+-- @+unapplyTy :: Type -> (Type, [Type])+unapplyTy ty = go ty ty []+ where+ go :: Type -> Type -> [Type] -> (Type, [Type])+ go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args)+ go origTy (SigT ty' _) args = go origTy ty' args+#if MIN_VERSION_template_haskell(2,11,0)+ go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args+ go origTy (ParensT ty') args = go origTy ty' args+#endif+ go origTy _ args = (origTy, args)++-- | Split a type signature by the arrows on its spine. For example, this:+--+-- @+-- forall a b. (a ~ b) => (a -> b) -> Char -> ()+-- @+--+-- would split to this:+--+-- @+-- (a ~ b, [a -> b, Char, ()])+-- @+uncurryTy :: Type -> (Cxt, [Type])+uncurryTy (AppT (AppT ArrowT t1) t2) =+ let (ctxt, tys) = uncurryTy t2+ in (ctxt, t1:tys)+uncurryTy (SigT t _) = uncurryTy t+uncurryTy (ForallT _ ctxt t) =+ let (ctxt', tys) = uncurryTy t+ in (ctxt ++ ctxt', tys)+uncurryTy t = ([], [t])++-- | 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+-------------------------------------------------------------------------------++-- 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"++bifoldrConstValName :: Name+bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst"++bifoldMapConstValName :: Name+bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst"++coerceValName :: Name+coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"++bitraverseConstValName :: Name+bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst"++wrapMonadDataName :: Name+wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"++functorTypeName :: Name+functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"++foldableTypeName :: Name+foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"++traversableTypeName :: Name+traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"++composeValName :: Name+composeValName = mkNameG_v "base" "GHC.Base" "."++idValName :: Name+idValName = mkNameG_v "base" "GHC.Base" "id"++errorValName :: Name+errorValName = mkNameG_v "base" "GHC.Err" "error"++flipValName :: Name+flipValName = mkNameG_v "base" "GHC.Base" "flip"++fmapValName :: Name+fmapValName = mkNameG_v "base" "GHC.Base" "fmap"++foldrValName :: Name+foldrValName = mkNameG_v "base" "Data.Foldable" "foldr"++foldMapValName :: Name+foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap"++seqValName :: Name+seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"++traverseValName :: Name+traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"++unwrapMonadValName :: Name+unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "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"++bimapValName :: Name+bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap"++pureValName :: Name+pureValName = mkNameG_v "base" "Control.Applicative" "pure"++apValName :: Name+apValName = mkNameG_v "base" "Control.Applicative" "<*>"++liftA2ValName :: Name+liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"++mappendValName :: Name+mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"++memptyValName :: Name+memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"+#endif++#if MIN_VERSION_base(4,10,0)+bifoldableTypeName :: Name+bifoldableTypeName = mkNameG_tc "base" "Data.Bifoldable" "Bifoldable"++bitraversableTypeName :: Name+bitraversableTypeName = mkNameG_tc "base" "Data.Bitraversable" "Bitraversable"++bifoldrValName :: Name+bifoldrValName = mkNameG_v "base" "Data.Bifoldable" "bifoldr"++bifoldMapValName :: Name+bifoldMapValName = mkNameG_v "base" "Data.Bifoldable" "bifoldMap"++bitraverseValName :: Name+bitraverseValName = mkNameG_v "base" "Data.Bitraversable" "bitraverse"+#else+bifoldableTypeName :: Name+bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable"++bitraversableTypeName :: Name+bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable"++bifoldrValName :: Name+bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr"++bifoldMapValName :: Name+bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap"++bitraverseValName :: Name+bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse"+#endif++#if MIN_VERSION_base(4,11,0)+appEndoValName :: Name+appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo"++dualDataName :: Name+dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual"++endoDataName :: Name+endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo"++getDualValName :: Name+getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual"+#else+appEndoValName :: Name+appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"++dualDataName :: Name+dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"++endoDataName :: Name+endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"++getDualValName :: Name+getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"+#endif
src/Data/Bifunctor/Tannen.hs view
@@ -1,211 +1,211 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# 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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- 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.Tannen - ( Tannen(..) - ) where - -import Control.Applicative - -import Control.Arrow as A -import Control.Category -import Control.Comonad - -import Data.Bifunctor as B -import Data.Bifunctor.Functor -import Data.Biapplicative -import Data.Bifoldable -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 GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 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 Constructor TannenMetaCons where - conName _ = "Tannen" - conIsRecord _ = True - -instance Selector TannenMetaSel where - selName _ = "runTannen" - -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 - -#if LIFTED_FUNCTOR_CLASSES -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 (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 (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 (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 '}' -#endif - -instance Functor f => BifunctorFunctor (Tannen f) where - bifmap f (Tannen fp) = Tannen (fmap f fp) - -instance (Functor f, Monad f) => BifunctorMonad (Tannen f) where - bireturn = Tannen . return - bibind f (Tannen fp) = Tannen $ fp >>= runTannen . f - -instance Comonad f => BifunctorComonad (Tannen f) where - biextract = extract . runTannen - biextend f (Tannen fp) = Tannen (extend (f . Tannen) fp) - -instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where - first f = Tannen . fmap (B.first f) . runTannen - {-# INLINE first #-} - second f = Tannen . fmap (B.second f) . runTannen - {-# INLINE second #-} - bimap f g = Tannen . fmap (bimap f g) . runTannen - {-# INLINE bimap #-} - -instance (Functor f, Bifunctor p) => Functor (Tannen f p a) where - fmap f = Tannen . fmap (B.second f) . runTannen - {-# INLINE fmap #-} - -instance (Applicative f, Biapplicative p) => Biapplicative (Tannen f p) where - bipure a b = Tannen (pure (bipure a b)) - {-# INLINE bipure #-} - - Tannen fg <<*>> Tannen xy = Tannen ((<<*>>) <$> fg <*> xy) - {-# INLINE (<<*>>) #-} - -instance (Foldable f, Bifoldable p) => Foldable (Tannen f p a) where - foldMap f = foldMap (bifoldMap (const mempty) f) . runTannen - {-# INLINE foldMap #-} - -instance (Foldable f, Bifoldable p) => Bifoldable (Tannen f p) where - bifoldMap f g = foldMap (bifoldMap f g) . runTannen - {-# INLINE bifoldMap #-} - -instance (Traversable f, Bitraversable p) => Traversable (Tannen f p a) where - traverse f = fmap Tannen . traverse (bitraverse pure f) . runTannen - {-# INLINE traverse #-} - -instance (Traversable f, Bitraversable p) => Bitraversable (Tannen f p) where - bitraverse f g = fmap Tannen . traverse (bitraverse f g) . runTannen - {-# INLINE bitraverse #-} - -instance (Applicative f, Category p) => Category (Tannen f p) where - id = Tannen $ pure id - Tannen fpbc . Tannen fpab = Tannen $ liftA2 (.) fpbc fpab - -instance (Applicative f, Arrow p) => Arrow (Tannen f p) where - arr f = Tannen $ pure $ arr f - first = Tannen . fmap A.first . runTannen - second = Tannen . fmap A.second . runTannen - Tannen ab *** Tannen cd = Tannen $ liftA2 (***) ab cd - Tannen ab &&& Tannen ac = Tannen $ liftA2 (&&&) ab ac - -instance (Applicative f, ArrowChoice p) => ArrowChoice (Tannen f p) where - left = Tannen . fmap left . runTannen - right = Tannen . fmap right . runTannen - Tannen ab +++ Tannen cd = Tannen $ liftA2 (+++) ab cd - Tannen ac ||| Tannen bc = Tannen $ liftA2 (|||) ac bc - -instance (Applicative f, ArrowLoop p) => ArrowLoop (Tannen f p) where - loop = Tannen . fmap loop . runTannen - -instance (Applicative f, ArrowZero p) => ArrowZero (Tannen f p) where - zeroArrow = Tannen $ pure zeroArrow - -instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where - Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g) - +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- 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.Tannen+ ( Tannen(..)+ ) where++import Control.Applicative++import Control.Arrow as A+import Control.Category+import Control.Comonad++import Data.Bifunctor as B+import Data.Bifunctor.Functor+import Data.Biapplicative+import Data.Bifoldable+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 GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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 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 Constructor TannenMetaCons where+ conName _ = "Tannen"+ conIsRecord _ = True++instance Selector TannenMetaSel where+ selName _ = "runTannen"++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++#if LIFTED_FUNCTOR_CLASSES+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 (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 (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 (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 '}'+#endif++instance Functor f => BifunctorFunctor (Tannen f) where+ bifmap f (Tannen fp) = Tannen (fmap f fp)++instance (Functor f, Monad f) => BifunctorMonad (Tannen f) where+ bireturn = Tannen . return+ bibind f (Tannen fp) = Tannen $ fp >>= runTannen . f++instance Comonad f => BifunctorComonad (Tannen f) where+ biextract = extract . runTannen+ biextend f (Tannen fp) = Tannen (extend (f . Tannen) fp)++instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where+ first f = Tannen . fmap (B.first f) . runTannen+ {-# INLINE first #-}+ second f = Tannen . fmap (B.second f) . runTannen+ {-# INLINE second #-}+ bimap f g = Tannen . fmap (bimap f g) . runTannen+ {-# INLINE bimap #-}++instance (Functor f, Bifunctor p) => Functor (Tannen f p a) where+ fmap f = Tannen . fmap (B.second f) . runTannen+ {-# INLINE fmap #-}++instance (Applicative f, Biapplicative p) => Biapplicative (Tannen f p) where+ bipure a b = Tannen (pure (bipure a b))+ {-# INLINE bipure #-}++ Tannen fg <<*>> Tannen xy = Tannen ((<<*>>) <$> fg <*> xy)+ {-# INLINE (<<*>>) #-}++instance (Foldable f, Bifoldable p) => Foldable (Tannen f p a) where+ foldMap f = foldMap (bifoldMap (const mempty) f) . runTannen+ {-# INLINE foldMap #-}++instance (Foldable f, Bifoldable p) => Bifoldable (Tannen f p) where+ bifoldMap f g = foldMap (bifoldMap f g) . runTannen+ {-# INLINE bifoldMap #-}++instance (Traversable f, Bitraversable p) => Traversable (Tannen f p a) where+ traverse f = fmap Tannen . traverse (bitraverse pure f) . runTannen+ {-# INLINE traverse #-}++instance (Traversable f, Bitraversable p) => Bitraversable (Tannen f p) where+ bitraverse f g = fmap Tannen . traverse (bitraverse f g) . runTannen+ {-# INLINE bitraverse #-}++instance (Applicative f, Category p) => Category (Tannen f p) where+ id = Tannen $ pure id+ Tannen fpbc . Tannen fpab = Tannen $ liftA2 (.) fpbc fpab++instance (Applicative f, Arrow p) => Arrow (Tannen f p) where+ arr f = Tannen $ pure $ arr f+ first = Tannen . fmap A.first . runTannen+ second = Tannen . fmap A.second . runTannen+ Tannen ab *** Tannen cd = Tannen $ liftA2 (***) ab cd+ Tannen ab &&& Tannen ac = Tannen $ liftA2 (&&&) ab ac++instance (Applicative f, ArrowChoice p) => ArrowChoice (Tannen f p) where+ left = Tannen . fmap left . runTannen+ right = Tannen . fmap right . runTannen+ Tannen ab +++ Tannen cd = Tannen $ liftA2 (+++) ab cd+ Tannen ac ||| Tannen bc = Tannen $ liftA2 (|||) ac bc++instance (Applicative f, ArrowLoop p) => ArrowLoop (Tannen f p) where+ loop = Tannen . fmap loop . runTannen++instance (Applicative f, ArrowZero p) => ArrowZero (Tannen f p) where+ zeroArrow = Tannen $ pure zeroArrow++instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where+ Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g)+
src/Data/Bifunctor/Wrapped.hs view
@@ -1,160 +1,160 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#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 -#include "bifunctors-common.h" - ------------------------------------------------------------------------------ --- | --- 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.Wrapped - ( WrappedBifunctor(..) - ) 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.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - -#if LIFTED_FUNCTOR_CLASSES -import Data.Functor.Classes -#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 - -instance Datatype WrappedBifunctorMetaData where - datatypeName = const "WrappedBifunctor" - moduleName = const "Data.Bifunctor.Wrapped" - -instance Constructor WrappedBifunctorMetaCons where - conName = const "WrapBifunctor" - conIsRecord = const True - -instance Selector WrappedBifunctorMetaSel where - selName = const "unwrapBifunctor" - -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 - -#if LIFTED_FUNCTOR_CLASSES -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 (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 (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 (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 '}' -#endif - -instance Bifunctor p => Bifunctor (WrappedBifunctor p) where - first f = WrapBifunctor . first f . unwrapBifunctor - {-# INLINE first #-} - second f = WrapBifunctor . second f . unwrapBifunctor - {-# INLINE second #-} - bimap f g = WrapBifunctor . bimap f g . unwrapBifunctor - {-# INLINE bimap #-} - -instance Bifunctor p => Functor (WrappedBifunctor p a) where - fmap f = WrapBifunctor . second f . unwrapBifunctor - {-# INLINE fmap #-} - -instance Biapplicative p => Biapplicative (WrappedBifunctor p) where - bipure a b = WrapBifunctor (bipure a b) - {-# INLINE bipure #-} - WrapBifunctor fg <<*>> WrapBifunctor xy = WrapBifunctor (fg <<*>> xy) - {-# INLINE (<<*>>) #-} - -instance Bifoldable p => Foldable (WrappedBifunctor p a) where - foldMap f = bifoldMap (const mempty) f . unwrapBifunctor - {-# INLINE foldMap #-} - -instance Bifoldable p => Bifoldable (WrappedBifunctor p) where - bifoldMap f g = bifoldMap f g . unwrapBifunctor - {-# INLINE bifoldMap #-} - -instance Bitraversable p => Traversable (WrappedBifunctor p a) where - traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor - {-# INLINE traverse #-} - -instance Bitraversable p => Bitraversable (WrappedBifunctor p) where - bitraverse f g = fmap WrapBifunctor . bitraverse f g . unwrapBifunctor - {-# INLINE bitraverse #-} +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#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+#include "bifunctors-common.h"++-----------------------------------------------------------------------------+-- |+-- 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.Wrapped+ ( WrappedBifunctor(..)+ ) 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.Monoid+import Data.Traversable+#endif++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++#if LIFTED_FUNCTOR_CLASSES+import Data.Functor.Classes+#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++instance Datatype WrappedBifunctorMetaData where+ datatypeName = const "WrappedBifunctor"+ moduleName = const "Data.Bifunctor.Wrapped"++instance Constructor WrappedBifunctorMetaCons where+ conName = const "WrapBifunctor"+ conIsRecord = const True++instance Selector WrappedBifunctorMetaSel where+ selName = const "unwrapBifunctor"++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++#if LIFTED_FUNCTOR_CLASSES+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 (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 (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 (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 '}'+#endif++instance Bifunctor p => Bifunctor (WrappedBifunctor p) where+ first f = WrapBifunctor . first f . unwrapBifunctor+ {-# INLINE first #-}+ second f = WrapBifunctor . second f . unwrapBifunctor+ {-# INLINE second #-}+ bimap f g = WrapBifunctor . bimap f g . unwrapBifunctor+ {-# INLINE bimap #-}++instance Bifunctor p => Functor (WrappedBifunctor p a) where+ fmap f = WrapBifunctor . second f . unwrapBifunctor+ {-# INLINE fmap #-}++instance Biapplicative p => Biapplicative (WrappedBifunctor p) where+ bipure a b = WrapBifunctor (bipure a b)+ {-# INLINE bipure #-}+ WrapBifunctor fg <<*>> WrapBifunctor xy = WrapBifunctor (fg <<*>> xy)+ {-# INLINE (<<*>>) #-}++instance Bifoldable p => Foldable (WrappedBifunctor p a) where+ foldMap f = bifoldMap (const mempty) f . unwrapBifunctor+ {-# INLINE foldMap #-}++instance Bifoldable p => Bifoldable (WrappedBifunctor p) where+ bifoldMap f g = bifoldMap f g . unwrapBifunctor+ {-# INLINE bifoldMap #-}++instance Bitraversable p => Traversable (WrappedBifunctor p a) where+ traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor+ {-# INLINE traverse #-}++instance Bitraversable p => Bitraversable (WrappedBifunctor p) where+ bitraverse f g = fmap WrapBifunctor . bitraverse f g . unwrapBifunctor+ {-# INLINE bitraverse #-}
tests/BifunctorSpec.hs view
@@ -1,542 +1,542 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE RoleAnnotations #-} -#endif - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-unused-foralls #-} -#endif - -{-| -Module: BifunctorSpec -Copyright: (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Edward Kmett -Portability: Template Haskell - -@hspec@ tests for the "Data.Bifunctor.TH" module. --} -module BifunctorSpec where - -import Data.Bifunctor -import Data.Bifunctor.TH -import Data.Bifoldable -import Data.Bitraversable - -import Data.Char (chr) -import Data.Functor.Classes (Eq1, Show1) -import Data.Functor.Compose (Compose(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Monoid - -import GHC.Exts (Int#) - -import Test.Hspec -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 --- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch - --- Plain data types - -data Strange a b c - = T1 a b c - | T2 [a] [b] [c] -- lists - | 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 - = T6 (a -> c) -- function types - | 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 - T11 :: Int -> StrangeGADT e Int - T12 :: c ~ Int => c -> StrangeGADT f Int - 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, 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) -#if __GLASGOW_HASKELL__ >= 708 -type role Empty2 nominal nominal -#endif - -data TyCon81 a b - = TyCon81a (forall c. c -> (forall d. a -> d) -> a) - | TyCon81b (Int -> forall c. c -> b) -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 -data instance StrangeFam a b c - = T1Fam a b c - | T2Fam [a] [b] [c] -- lists - | T3Fam [[a]] [[b]] [[c]] -- nested lists - | T4Fam (c,(b,b),(c,c)) -- tuples - | T5Fam ([c],Strange a b c) -- tycons -#if __GLASGOW_HASKELL__ >= 708 - -- Unfortunately, pre-7.8 versions of GHC suffer from a bug that prevents - -- deriving Functor for data family instances. We could write all of the - -- derived instances by hand, but that amount of boilerplate makes me - -- nauseous. Instead, I elect to guard the derived instances with CPP. - deriving (Functor, Foldable, Traversable) -#endif - -data family StrangeFunctionsFam x y z -data instance StrangeFunctionsFam a b c - = T6Fam (a -> c) -- function types - | T7Fam (a -> (c,a)) -- functions and tuples - | T8Fam ((b -> a) -> c) -- continuation - | T9Fam (IntFun b c) -- type synonyms -#if __GLASGOW_HASKELL__ >= 708 - deriving Functor -#endif - -data family StrangeGADTFam x y -data instance StrangeGADTFam a b where - T10Fam :: Ord d => d -> StrangeGADTFam c d - T11Fam :: Int -> StrangeGADTFam e Int - T12Fam :: c ~ Int => c -> StrangeGADTFam f Int - 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 -#if __GLASGOW_HASKELL__ >= 708 - deriving (Functor, Foldable, Traversable) -#endif - -data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y -newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b)) - deriving ( Arbitrary, Eq, Show -#if __GLASGOW_HASKELL__ >= 708 - , Functor, Foldable, Traversable -#endif - ) - -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 - = UniversalFam (forall b. (b,[a])) - | 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)) -#if __GLASGOW_HASKELL__ >= 708 - deriving (Functor, Foldable) --- Old versions of GHC are unable to derive Traversable instances for data types --- with fields of unlifted types, so write this one by hand. -instance Traversable (IntHashFam a) where - traverse f (IntHashFam x y) = pure (IntHashFam x y) - traverse f (IntHashTupleFam x y z (a,b,c,d)) = - (\z' b' d' -> IntHashTupleFam x y z' (a,b',c,d')) - `fmap` f z - <*> f b - <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d -#endif - -data family IntHashFunFam x y -data instance IntHashFunFam a b - = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) -#if __GLASGOW_HASKELL__ >= 708 - deriving Functor -#endif - -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) -#if __GLASGOW_HASKELL__ >= 708 - deriving (Functor, Foldable, Traversable) -#endif - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveBifunctor ''Strange) -$(deriveBifoldable ''Strange) -$(deriveBitraversable ''Strange) - -$(deriveBifunctor ''StrangeFunctions) -$(deriveBifoldable ''StrangeGADT) - -$(deriveBifunctor ''NotPrimitivelyRecursive) -$(deriveBifoldable ''NotPrimitivelyRecursive) -$(deriveBitraversable ''NotPrimitivelyRecursive) - -$(deriveBifunctor ''OneTwoCompose) -$(deriveBifoldable ''OneTwoCompose) -$(deriveBitraversable ''OneTwoCompose) - -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) -$(deriveBifoldable ''Existential) -$(deriveBitraversable ''Existential) - -$(deriveBifunctor ''IntHash) -$(deriveBifoldable ''IntHash) -$(deriveBitraversable ''IntHash) - -$(deriveBifunctor ''IntHashFun) - -$(deriveBifunctor ''Empty1) -$(deriveBifoldable ''Empty1) -$(deriveBitraversable ''Empty1) - --- Use EmptyCase here -$(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) -$(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) -$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) - -$(deriveBifunctor ''TyCon81) - -$(deriveBifunctor ''TyCon82) -$(deriveBifoldable ''TyCon82) -$(deriveBitraversable ''TyCon82) - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveBifunctor 'T1Fam) -$(deriveBifoldable 'T2Fam) -$(deriveBitraversable 'T3Fam) - -$(deriveBifunctor 'T6Fam) -$(deriveBifoldable 'T10Fam) - -$(deriveBifunctor 'S1Fam) -$(deriveBifoldable 'S2Fam) -$(deriveBitraversable 'S3Fam) - -$(deriveBifunctor 'OneTwoComposeFam) -$(deriveBifoldable 'OneTwoComposeFam) -$(deriveBitraversable 'OneTwoComposeFam) - -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) -$(deriveBifoldable 'ExistentialFunctorFam) -$(deriveBitraversable 'SneakyUseSameNameFam) - -$(deriveBifunctor 'IntHashFam) -$(deriveBifoldable 'IntHashTupleFam) -$(deriveBitraversable 'IntHashFam) - -$(deriveBifunctor 'IntHashFunFam) - -$(deriveBifunctor 'TyFamily81a) - -$(deriveBifunctor 'TyFamily82) -$(deriveBifoldable 'TyFamily82) -$(deriveBitraversable 'TyFamily82) -#endif - -------------------------------------------------------------------------------- - -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]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation -prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42]) - -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 -> 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] -> 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, - 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 -> 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]), - 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)) - (++ "hello") - (++ "world") - reverse - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "OneTwoCompose Maybe Either [Int] [Int]" $ do - prop "satisfies the Bifunctor laws" - (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) - prop "satisfies the Bifoldable laws" - (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) - prop "satisfies the Bitraversable laws" - (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) -#if MIN_VERSION_template_haskell(2,7,0) - describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do - prop "satisfies the Bifunctor laws" - (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) - prop "satisfies the Bifoldable laws" - (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) - prop "satisfies the Bitraversable laws" - (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE RoleAnnotations #-}+#endif++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fno-warn-unused-foralls #-}+#endif++{-|+Module: BifunctorSpec+Copyright: (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Edward Kmett+Portability: Template Haskell++@hspec@ tests for the "Data.Bifunctor.TH" module.+-}+module BifunctorSpec where++import Data.Bifunctor+import Data.Bifunctor.TH+import Data.Bifoldable+import Data.Bitraversable++import Data.Char (chr)+import Data.Functor.Classes (Eq1, Show1)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid++import GHC.Exts (Int#)++import Test.Hspec+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+-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch++-- Plain data types++data Strange a b c+ = T1 a b c+ | T2 [a] [b] [c] -- lists+ | 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+ = T6 (a -> c) -- function types+ | 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+ T11 :: Int -> StrangeGADT e Int+ T12 :: c ~ Int => c -> StrangeGADT f Int+ 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, 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)+#if __GLASGOW_HASKELL__ >= 708+type role Empty2 nominal nominal+#endif++data TyCon81 a b+ = TyCon81a (forall c. c -> (forall d. a -> d) -> a)+ | TyCon81b (Int -> forall c. c -> b)+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+data instance StrangeFam a b c+ = T1Fam a b c+ | T2Fam [a] [b] [c] -- lists+ | T3Fam [[a]] [[b]] [[c]] -- nested lists+ | T4Fam (c,(b,b),(c,c)) -- tuples+ | T5Fam ([c],Strange a b c) -- tycons+#if __GLASGOW_HASKELL__ >= 708+ -- Unfortunately, pre-7.8 versions of GHC suffer from a bug that prevents+ -- deriving Functor for data family instances. We could write all of the+ -- derived instances by hand, but that amount of boilerplate makes me+ -- nauseous. Instead, I elect to guard the derived instances with CPP.+ deriving (Functor, Foldable, Traversable)+#endif++data family StrangeFunctionsFam x y z+data instance StrangeFunctionsFam a b c+ = T6Fam (a -> c) -- function types+ | T7Fam (a -> (c,a)) -- functions and tuples+ | T8Fam ((b -> a) -> c) -- continuation+ | T9Fam (IntFun b c) -- type synonyms+#if __GLASGOW_HASKELL__ >= 708+ deriving Functor+#endif++data family StrangeGADTFam x y+data instance StrangeGADTFam a b where+ T10Fam :: Ord d => d -> StrangeGADTFam c d+ T11Fam :: Int -> StrangeGADTFam e Int+ T12Fam :: c ~ Int => c -> StrangeGADTFam f Int+ 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+#if __GLASGOW_HASKELL__ >= 708+ deriving (Functor, Foldable, Traversable)+#endif++data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y+newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b))+ deriving ( Arbitrary, Eq, Show+#if __GLASGOW_HASKELL__ >= 708+ , Functor, Foldable, Traversable+#endif+ )++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+ = UniversalFam (forall b. (b,[a]))+ | 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))+#if __GLASGOW_HASKELL__ >= 708+ deriving (Functor, Foldable)+-- Old versions of GHC are unable to derive Traversable instances for data types+-- with fields of unlifted types, so write this one by hand.+instance Traversable (IntHashFam a) where+ traverse f (IntHashFam x y) = pure (IntHashFam x y)+ traverse f (IntHashTupleFam x y z (a,b,c,d)) =+ (\z' b' d' -> IntHashTupleFam x y z' (a,b',c,d'))+ `fmap` f z+ <*> f b+ <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d+#endif++data family IntHashFunFam x y+data instance IntHashFunFam a b+ = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)+#if __GLASGOW_HASKELL__ >= 708+ deriving Functor+#endif++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)+#if __GLASGOW_HASKELL__ >= 708+ deriving (Functor, Foldable, Traversable)+#endif++-------------------------------------------------------------------------------++-- Plain data types++$(deriveBifunctor ''Strange)+$(deriveBifoldable ''Strange)+$(deriveBitraversable ''Strange)++$(deriveBifunctor ''StrangeFunctions)+$(deriveBifoldable ''StrangeGADT)++$(deriveBifunctor ''NotPrimitivelyRecursive)+$(deriveBifoldable ''NotPrimitivelyRecursive)+$(deriveBitraversable ''NotPrimitivelyRecursive)++$(deriveBifunctor ''OneTwoCompose)+$(deriveBifoldable ''OneTwoCompose)+$(deriveBitraversable ''OneTwoCompose)++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)+$(deriveBifoldable ''Existential)+$(deriveBitraversable ''Existential)++$(deriveBifunctor ''IntHash)+$(deriveBifoldable ''IntHash)+$(deriveBitraversable ''IntHash)++$(deriveBifunctor ''IntHashFun)++$(deriveBifunctor ''Empty1)+$(deriveBifoldable ''Empty1)+$(deriveBitraversable ''Empty1)++-- Use EmptyCase here+$(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)+$(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)+$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)++$(deriveBifunctor ''TyCon81)++$(deriveBifunctor ''TyCon82)+$(deriveBifoldable ''TyCon82)+$(deriveBitraversable ''TyCon82)++#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveBifunctor 'T1Fam)+$(deriveBifoldable 'T2Fam)+$(deriveBitraversable 'T3Fam)++$(deriveBifunctor 'T6Fam)+$(deriveBifoldable 'T10Fam)++$(deriveBifunctor 'S1Fam)+$(deriveBifoldable 'S2Fam)+$(deriveBitraversable 'S3Fam)++$(deriveBifunctor 'OneTwoComposeFam)+$(deriveBifoldable 'OneTwoComposeFam)+$(deriveBitraversable 'OneTwoComposeFam)++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)+$(deriveBifoldable 'ExistentialFunctorFam)+$(deriveBitraversable 'SneakyUseSameNameFam)++$(deriveBifunctor 'IntHashFam)+$(deriveBifoldable 'IntHashTupleFam)+$(deriveBitraversable 'IntHashFam)++$(deriveBifunctor 'IntHashFunFam)++$(deriveBifunctor 'TyFamily81a)++$(deriveBifunctor 'TyFamily82)+$(deriveBifoldable 'TyFamily82)+$(deriveBitraversable 'TyFamily82)+#endif++-------------------------------------------------------------------------------++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]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation+prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42])++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 -> 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] -> 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,+ 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 -> 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]),+ 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))+ (++ "hello")+ (++ "world")+ reverse++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "OneTwoCompose Maybe Either [Int] [Int]" $ do+ prop "satisfies the Bifunctor laws"+ (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation)+ prop "satisfies the Bifoldable laws"+ (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation)+ prop "satisfies the Bitraversable laws"+ (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation)+#if MIN_VERSION_template_haskell(2,7,0)+ describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do+ prop "satisfies the Bifunctor laws"+ (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)+ prop "satisfies the Bifoldable laws"+ (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)+ prop "satisfies the Bitraversable laws"+ (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)+#endif
tests/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
tests/T89Spec.hs view
@@ -1,21 +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 () +{-# 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 ()