bifunctors 5.5.13 → 5.5.14
raw patch · 27 files changed
+6041/−5885 lines, 27 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Bifunctor.Product: instance forall k (f :: k -> * -> *) (a :: k) (g :: k -> * -> *). (Data.Foldable.Foldable (f a), Data.Foldable.Foldable (g a)) => Data.Foldable.Foldable (Data.Bifunctor.Product.Product f g a)
+ Data.Bifunctor.Product: instance forall k (f :: k -> * -> *) (a :: k) (g :: k -> * -> *). (Data.Traversable.Traversable (f a), Data.Traversable.Traversable (g a)) => Data.Traversable.Traversable (Data.Bifunctor.Product.Product f g a)
+ Data.Bifunctor.Product: instance forall k (f :: k -> * -> *) (a :: k) (g :: k -> * -> *). (GHC.Base.Functor (f a), GHC.Base.Functor (g a)) => GHC.Base.Functor (Data.Bifunctor.Product.Product f g a)
+ Data.Bifunctor.Sum: instance forall k (f :: k -> * -> *) (a :: k) (g :: k -> * -> *). (Data.Foldable.Foldable (f a), Data.Foldable.Foldable (g a)) => Data.Foldable.Foldable (Data.Bifunctor.Sum.Sum f g a)
+ Data.Bifunctor.Sum: instance forall k (f :: k -> * -> *) (a :: k) (g :: k -> * -> *). (Data.Traversable.Traversable (f a), Data.Traversable.Traversable (g a)) => Data.Traversable.Traversable (Data.Bifunctor.Sum.Sum f g a)
+ Data.Bifunctor.Sum: instance forall k (f :: k -> * -> *) (a :: k) (g :: k -> * -> *). (GHC.Base.Functor (f a), GHC.Base.Functor (g a)) => GHC.Base.Functor (Data.Bifunctor.Sum.Sum f g a)
Files
- CHANGELOG.markdown +184/−179
- LICENSE +26/−26
- README.markdown +13/−13
- Setup.lhs +7/−7
- bifunctors.cabal +139/−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/−180
- src/Data/Bifunctor/Sum.hs +146/−136
- src/Data/Bifunctor/TH.hs +1334/−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/−408
- tests/Spec.hs +1/−1
- tests/T89Spec.hs +21/−21
CHANGELOG.markdown view
@@ -1,179 +1,184 @@-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.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,139 @@-name: bifunctors-category: Data, Functors-version: 5.5.13-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.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 +
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,180 +1,187 @@-{-# 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 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--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif--import qualified Control.Arrow as A-import Control.Category-import Data.Biapplicative-import Data.Bifoldable-import Data.Bifunctor.Functor-import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Monoid hiding (Product)-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702-import 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- )--#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,136 +1,146 @@-{-# 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"--module Data.Bifunctor.Sum where--import Data.Bifunctor-import Data.Bifunctor.Functor-import Data.Bifoldable-import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Functor-import Data.Monoid hiding (Sum)-#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- )--#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,1334 @@-{-# 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 +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
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,408 +1,542 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# 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--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--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--data NotPrimitivelyRecursive a b- = S1 (NotPrimitivelyRecursive (a,a) (b, a))- | S2 a- | S3 b--newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b))- deriving (Arbitrary, Eq, Show)--newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b))--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)--data Existential a b- = forall a. ExistentialList [a]- | forall f. Bitraversable f => ExistentialFunctor (f a b)- | forall b. SneakyUseSameName (Maybe b)--data IntHash a b- = IntHash Int# Int#- | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int))--data IntHashFun a b- = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a)--data Empty1 a b-data Empty2 a b-#if __GLASGOW_HASKELL__ >= 708-type role Empty2 nominal nominal-#endif--data TyCon81 a b- = TyCon81a (forall c. c -> (forall d. a -> d) -> a)- | TyCon81b (Int -> forall c. c -> b)--type family F :: * -> * -> *-type instance F = Either--data TyCon82 a b = TyCon82 (F a b)---- Data families--data family StrangeFam x y z-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--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--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--data family NotPrimitivelyRecursiveFam x y-data instance NotPrimitivelyRecursiveFam a b- = S1Fam (NotPrimitivelyRecursive (a,a) (b, a))- | S2Fam a- | S3Fam b--data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y-newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b))- deriving (Arbitrary, Eq, Show)--data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y-newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b))--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)--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)--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))--data family IntHashFunFam x y-data instance IntHashFunFam a b- = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)--data family TyFamily81 x y-data instance TyFamily81 a b- = TyFamily81a (forall c. c -> (forall d. a -> d) -> a)- | TyFamily81b (Int -> forall c. c -> b)--data family TyFamily82 x y-data instance TyFamily82 a b = TyFamily82 (F a b)------------------------------------------------------------------------------------- Plain data types--$(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 ()