diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,49 +0,0 @@ -env: - - GHCVER=7.0.4 CABALVER=1.18 - - GHCVER=7.2.2 CABALVER=1.18 - - GHCVER=7.4.2 CABALVER=1.18 - - GHCVER=7.6.3 CABALVER=1.18 - - GHCVER=7.8.4 CABALVER=1.18 - - GHCVER=7.10.3 CABALVER=1.22 - - GHCVER=8.0.1 CABALVER=1.24 - - GHCVER=head CABALVER=1.24 - -matrix: - allow_failures: - - env: GHCVER=head CABALVER=1.24 - - env: GHCVER=7.0.4 CABALVER=1.18 - - env: GHCVER=7.2.2 CABALVER=1.18 - -before_install: - - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - - travis_retry sudo apt-get update - - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - - cabal --version - -install: - - travis_retry cabal update - - cabal install --enable-tests --only-dependencies - - export PATH=$HOME/.cabal/bin:$PATH # Needed to be able to find hspec-discover - -script: - - cabal configure -v2 --enable-tests - - cabal build - - cabal test --show-details=always - - cabal sdist - - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313bifunctors\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,201 @@ +5.6.3 [2026.01.03] +------------------ +* Allow building with `template-haskell-2.24.*` (GHC 9.14). +* Remove unused dependencies. + +5.6.2 [2024.03.19] +------------------ +* Support building with `template-haskell-2.22.*` (GHC 9.10). + +5.6.1 [2023.03.13] +------------------ +* Provide instances for the `Swap` and `Assoc` type classes from the `assoc` + package. (These instances were previously defined in `assoc` itself, but they + have been migrated over to `bifunctors` in tandem with the `assoc-1.1` + release.) +* Only depend on `bifunctor-classes-compat` if building with GHC 8.0. + +5.6 [2023.03.12] +---------------- +* Drop support for GHC 7.10 and earlier. +* Move the `Data.Bifunctor`, `Data.Bifoldable`, and `Data.Bitraversable` + compatibility modules to the new `bifunctor-classes-compat` package. For + backwards compatibility, the `bifunctors` library re-exports + `Data.Bifoldable` and `Data.Bitraversable` modules from + `bifunctor-classes-compat` when building with GHC 8.0. + + If your library depends on `bifunctors` and compiles with pre-8.2 + versions of GHC, be warned that it may be possible to construct a + build plan involving a pre-`5.6` version of `bifunctors` where: + + * Some of the `Bifunctor` instances come from + `bifunctor-classes-compat`'s compatibility classes, and + * Other `Bifunctor` instances come from `bifunctors`'s compatibility classes. + + These compatibility classes are distinct, so this could lead to build errors + under certain conditions. Some possible ways to mitigate this risk include: + + * Drop support for GHC 8.0 and older in your library. + * Require `bifunctors >= 5.6` in your library. + * If neither of the options above are viable, then you can temporarily + define instances for the old compatibility classes from `bifunctors` like + so: + + ```hs + -- For Bifunctor instances + import qualified "bifunctor-classes-compat" Data.Bifunctor as BifunctorCompat + #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,8,0) + import qualified "bifunctors" Data.Bifunctor as Bifunctor + #endif + + instance BifunctorCompat.Bifunctor MyType where ... + + #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,8,0) + instance Bifunctor.Bifunctor MyType where ... + #endif + ``` + + ```hs + -- For Bifoldable and Bitraversable instances + import qualified "bifunctor-classes-compat" Data.Bifoldable as BifoldableCompat + import qualified "bifunctor-classes-compat" Data.Bitraversable as BitraversableCompat + #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,10,0) + import qualified "bifunctors" Data.Bifoldable as Bifoldable + import qualified "bifunctors" Data.Bitraversable as Bitraversable + #endif + + instance BifoldableCompat.Bifoldable MyType where ... + instance BitraversableCompat.Bitraversable MyType where ... + + #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,10,0) + instance Bifoldable.Bifoldable MyType where ... + instance Bitraversable.Bitraversable MyType where ... + #endif + ``` + + If your package does nothing but define instances of `Bifunctor` _et al._, + you may consider replacing your `bifunctors` dependency with + `bifunctor-classes-compat` to reduce your dependency footprint. If you do, + it is strongly recommended that you bump your package's major version number + so that your users are alerted to the details of the migration. +* Define a `Foldable1` instance for `Joker`, and define `Bifoldable1` instances + for `Biff`, `Clown`, `Flip`, `Join`, `Joker`, `Product`, `Tannen`, and + `WrappedBifunctor`. These instances were originally defined in the + `semigroupoids` library, and they have now been migrated to `bifunctors` as + a side effect of adapting to + [this Core Libraries Proposal](https://github.com/haskell/core-libraries-committee/issues/9), + which adds `Foldable1` and `Bifoldable1` to `base`. + +5.5.15 [2023.02.27] +------------------- +* Support `th-abstraction-0.5.*`. + +5.5.14 [2022.12.07] +------------------- +* Define `Functor`, `Foldable`, and `Traversable` instances for `Sum` and + `Product`. + +5.5.13 [2022.09.12] +------------------- +* Make the `Biapplicative` instances for tuples lazy, to match their `Bifunctor` + instances. + +5.5.12 [2022.05.07] +------------------- +* Backport an upstream GHC change which removes the default implementation of + `bitraverse`. Per the discussion in + https://github.com/haskell/core-libraries-committee/issues/47, this default + implementation was completely broken, as attempting to use it would always + result in an infinite loop. + +5.5.11 [2021.04.30] +------------------- +* Allow building with `template-haskell-2.18` (GHC 9.2). + +5.5.10 [2021.01.21] +------------------- +* Fix a bug in which `deriveBifoldable` could generate code that triggers + `-Wunused-matches` warnings. + +5.5.9 [2020.12.30] +------------------ +* Explicitly mark modules as Safe or Trustworthy. + +5.5.8 [2020.10.01] +------------------ +* Fix a bug in which `deriveBifunctor` would fail on sufficiently complex uses + of rank-n types in constructor fields. +* Fix a bug in which `deriveBiunctor` and related functions would needlessly + reject data types whose two last type parameters appear as oversaturated + arguments to a type family. + +5.5.7 [2020.01.29] +------------------ +* Add `Data.Bifunctor.Biap`. + +5.5.6 [2019.11.26] +------------------ +* Add `Category`, `Arrow`, `ArrowChoice`, `ArrowLoop`, `ArrowZero`, and + `ArrowPlus` instances for `Data.Bifunctor.Product`. + +5.5.5 [2019.08.27] +------------------ +* Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for data + types in the `Data.Bifunctor.*` module namespace where possible. The + operative phrase is "where possible" since many of these instances require + the use of `Eq2`/`Ord2`/`Read2`/`Show2`, which are not available when + built against `transformers-0.4.*`. + +5.5.4 [2019.04.26] +------------------ +* Support `th-abstraction-0.3` or later. +* Don't incur a `semigroup` dependency on recent GHCs. + +5.5.3 [2018.07.04] +------------------ +* Make `biliftA2` a class method of `Biapplicative`. +* Add the `traverseBia`, `sequenceBia`, and `traverseBiaWith` functions for + traversing a `Traversable` container in a `Biapplicative`. +* Avoid incurring some dependencies when using recent GHCs. + +5.5.2 [2018.02.06] +------------------ +* Don't enable `Safe` on GHC 7.2. + +5.5.1 [2018.02.04] +------------------ +* Test suite fixes for GHC 8.4. + +5.5 [2017.12.07] +---------------- +* `Data.Bifunctor.TH` now derives `bimap`/`bitraverse` + implementations for empty data types that are strict in the argument. +* `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations + that error on empty data types. Instead, they simply return the folded state + (for `bifoldr`) or `mempty` (for `bifoldMap`). +* When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable` + instances for data types where the last two type variables are at phantom + roles, generated `bimap`/`bitraverse` implementations now use `coerce` for + efficiency. +* Add `Options` to `Data.Bifunctor.TH`, along with variants of existing + functions that take `Options` as an argument. For now, the only configurable + option is whether derived instances for empty data types should use the + `EmptyCase` extension (this is disabled by default). + +5.4.2 +----- +* Make `deriveBitraversable` use `liftA2` in derived implementations of `bitraverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2) +* 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` diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ bifunctors ========== -[![Hackage](https://img.shields.io/hackage/v/bifunctors.svg)](https://hackage.haskell.org/package/bifunctors) [![Build Status](https://secure.travis-ci.org/ekmett/bifunctors.png?branch=master)](http://travis-ci.org/ekmett/bifunctors) +[![Hackage](https://img.shields.io/hackage/v/bifunctors.svg)](https://hackage.haskell.org/package/bifunctors) [![Build Status](https://github.com/ekmett/bifunctors/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/bifunctors/actions?query=workflow%3AHaskell-CI) Contact Information ------------------- diff --git a/bifunctors.cabal b/bifunctors.cabal --- a/bifunctors.cabal +++ b/bifunctors.cabal @@ -1,8 +1,8 @@ +cabal-version: 1.24 name: bifunctors category: Data, Functors -version: 5.3 +version: 5.6.3 license: BSD3 -cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -11,22 +11,29 @@ bug-reports: http://github.com/ekmett/bifunctors/issues copyright: Copyright (C) 2008-2016 Edward A. Kmett synopsis: Bifunctors -description: Bifunctors +description: Bifunctors. build-type: Simple -tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 -extra-source-files: .travis.yml CHANGELOG.markdown README.markdown +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 +extra-source-files: + CHANGELOG.markdown + README.markdown source-repository head type: git - location: git://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. + location: https://github.com/ekmett/bifunctors.git flag tagged default: True @@ -39,30 +46,32 @@ library hs-source-dirs: src build-depends: - base >= 4 && < 5, - base-orphans >= 0.5.2 && < 1, - comonad >= 4 && < 6, - containers >= 0.1 && < 0.6, - template-haskell >= 2.4 && < 2.12, - transformers >= 0.2 && < 0.6, - transformers-compat >= 0.5 && < 0.6 + base >= 4.9 && < 5, + assoc >= 1.1 && < 1.2, + comonad >= 5.0.7 && < 6, + containers >= 0.5.7.1 && < 0.9, + template-haskell >= 2.11 && < 2.25, + th-abstraction >= 0.4.2.0 && < 0.8 - if flag(tagged) - build-depends: tagged >= 0.7.3 && < 1 + if !impl(ghc >= 8.2) + build-depends: + bifunctor-classes-compat >= 0.1 && < 0.2, + transformers-compat >= 0.6 && < 0.8 - if flag(semigroups) - build-depends: semigroups >= 0.8.3.1 && < 1 + if flag(tagged) + build-depends: tagged >= 0.8.6 && < 1 - if impl(ghc<7.9) - hs-source-dirs: old-src - exposed-modules: Data.Bifunctor + if impl(ghc<8.1) + reexported-modules: + Data.Bifoldable + , Data.Bitraversable - if impl(ghc>=7.2) && impl(ghc<7.5) - build-depends: ghc-prim == 0.2.0.0 + if !impl(ghc >= 9.6) + build-depends: foldable1-classes-compat >= 0.1 && < 0.2 exposed-modules: Data.Biapplicative - Data.Bifoldable + Data.Bifunctor.Biap Data.Bifunctor.Biff Data.Bifunctor.Clown Data.Bifunctor.Fix @@ -75,26 +84,30 @@ Data.Bifunctor.Tannen Data.Bifunctor.TH Data.Bifunctor.Wrapped - Data.Bitraversable other-modules: Data.Bifunctor.TH.Internal - Paths_bifunctors ghc-options: -Wall + default-language: Haskell2010 + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode test-suite bifunctors-spec type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs - other-modules: BifunctorSpec + other-modules: BifunctorSpec T89Spec ghc-options: -Wall + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover >= 1.8 build-depends: base >= 4 && < 5, bifunctors, hspec >= 1.8, - QuickCheck >= 2 && < 3, - transformers, - transformers-compat - + QuickCheck >= 2 && < 3 diff --git a/old-src/Data/Bifunctor.hs b/old-src/Data/Bifunctor.hs deleted file mode 100644 --- a/old-src/Data/Bifunctor.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} - -#ifndef MIN_VERSION_semigroups -#define MIN_VERSION_semigroups(x,y,z) 0 -#endif ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- ----------------------------------------------------------------------------- -module Data.Bifunctor - ( -- * Overview - -- - -- Bifunctors extend the standard 'Functor' to two arguments - - -- * Examples - -- $examples - Bifunctor(..) - ) where - -import Control.Applicative -import Data.Functor.Constant - -#if MIN_VERSION_semigroups(0,16,2) -import Data.Semigroup -#endif - -#ifdef MIN_VERSION_tagged -import Data.Tagged -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (K1(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - --- | Minimal definition either 'bimap' or 'first' and 'second' - --- | Formally, the class 'Bifunctor' represents a bifunctor --- from @Hask@ -> @Hask@. --- --- Intuitively it is a bifunctor where both the first and second arguments are covariant. --- --- You can define a 'Bifunctor' by either defining 'bimap' or by defining both --- 'first' and 'second'. --- --- If you supply 'bimap', you should ensure that: --- --- @'bimap' 'id' 'id' ≡ 'id'@ --- --- If you supply 'first' and 'second', ensure: --- --- @ --- 'first' 'id' ≡ 'id' --- 'second' 'id' ≡ 'id' --- @ --- --- If you supply both, you should also ensure: --- --- @'bimap' f g ≡ 'first' f '.' 'second' g@ --- --- These ensure by parametricity: --- --- @ --- 'bimap' (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i --- 'first' (f '.' g) ≡ 'first' f '.' 'first' g --- 'second' (f '.' g) ≡ 'second' f '.' 'second' g --- @ -class Bifunctor p where - -- | Map over both arguments at the same time. - -- - -- @'bimap' f g ≡ 'first' f '.' 'second' g@ - bimap :: (a -> b) -> (c -> d) -> p a c -> p b d - bimap f g = first f . second g - {-# INLINE bimap #-} - - -- | Map covariantly over the first argument. - -- - -- @'first' f ≡ 'bimap' f 'id'@ - first :: (a -> b) -> p a c -> p b c - first f = bimap f id - {-# INLINE first #-} - - -- | Map covariantly over the second argument. - -- - -- @'second' ≡ 'bimap' 'id'@ - second :: (b -> c) -> p a b -> p a c - second = bimap id - {-# INLINE second #-} - -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL bimap | first, second #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -deriving instance Typeable Bifunctor -#endif - -instance Bifunctor (,) where - bimap f g ~(a, b) = (f a, g b) - {-# INLINE bimap #-} - -#if MIN_VERSION_semigroups(0,16,2) -instance Bifunctor Arg where - bimap f g (Arg a b) = Arg (f a) (g b) -#endif - -instance Bifunctor ((,,) x) where - bimap f g ~(x, a, b) = (x, f a, g b) - {-# INLINE bimap #-} - -instance Bifunctor ((,,,) x y) where - bimap f g ~(x, y, a, b) = (x, y, f a, g b) - {-# INLINE bimap #-} - -instance Bifunctor ((,,,,) x y z) where - bimap f g ~(x, y, z, a, b) = (x, y, z, f a, g b) - {-# INLINE bimap #-} - -instance Bifunctor ((,,,,,) x y z w) where - bimap f g ~(x, y, z, w, a, b) = (x, y, z, w, f a, g b) - {-# INLINE bimap #-} - -instance Bifunctor ((,,,,,,) x y z w v) where - bimap f g ~(x, y, z, w, v, a, b) = (x, y, z, w, v, f a, g b) - {-# INLINE bimap #-} - -instance Bifunctor Either where - bimap f _ (Left a) = Left (f a) - bimap _ g (Right b) = Right (g b) - {-# INLINE bimap #-} - -instance Bifunctor Const where - bimap f _ (Const a) = Const (f a) - {-# INLINE bimap #-} - -instance Bifunctor Constant where - bimap f _ (Constant a) = Constant (f a) - {-# INLINE bimap #-} - -#if __GLASGOW_HASKELL__ >= 702 -instance Bifunctor (K1 i) where - bimap f _ (K1 c) = K1 (f c) - {-# INLINE bimap #-} -#endif - -#ifdef MIN_VERSION_tagged -instance Bifunctor Tagged where - bimap _ g (Tagged b) = Tagged (g b) - {-# INLINE bimap #-} -#endif - --- $examples --- --- ==== __Examples__ --- --- While the standard 'Functor' instance for 'Either' is limited to mapping over 'Right' arguments, --- the 'Bifunctor' instance allows mapping over the 'Left', 'Right', or both arguments: --- --- > let x = Left "foo" :: Either String Integer --- --- In the case of 'first' and 'second', the function may or may not be applied: --- --- > first (++ "bar") x == Left "foobar" --- > second (+2) x == Left "foo" --- --- In the case of 'bimap', only one of the functions will be applied: --- --- > bimap (++ "bar") (+2) x == Left "foobar" --- --- The 'Bifunctor' instance for 2 element tuples allows mapping over one or both of the elements: --- --- > let x = ("foo",1) --- > --- > first (++ "bar") x == ("foobar", 1) --- > second (+2) x == ("foo", 3) --- > bimap (++ "bar") (+2) x == ("foobar", 3) diff --git a/src/Data/Biapplicative.hs b/src/Data/Biapplicative.hs --- a/src/Data/Biapplicative.hs +++ b/src/Data/Biapplicative.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} -#ifndef MIN_VERSION_semigroups -#define MIN_VERSION_semigroups(x,y,z) 0 -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -18,21 +19,18 @@ Biapplicative(..) , (<<$>>) , (<<**>>) - , biliftA2 , biliftA3 + , traverseBia + , sequenceBia + , traverseBiaWith , module Data.Bifunctor ) where import Control.Applicative import Data.Bifunctor - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) +import Data.Functor.Identity import Data.Semigroup (Arg(..)) -#endif +import GHC.Exts (inline) #ifdef MIN_VERSION_tagged import Data.Tagged @@ -44,16 +42,24 @@ {-# INLINE (<<$>>) #-} class Bifunctor p => Biapplicative p where + {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-} bipure :: a -> b -> p a b (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d + (<<*>>) = biliftA2 id id + {-# INLINE (<<*>>) #-} + -- | Lift binary functions + biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f + biliftA2 f g a b = bimap f g <<$>> a <<*>> b + {-# INLINE biliftA2 #-} + -- | -- @ -- a '*>>' b ≡ 'bimap' ('const' 'id') ('const' 'id') '<<$>>' a '<<*>>' b -- @ (*>>) :: p a b -> p c d -> p c d - a *>> b = bimap (const id) (const id) <<$>> a <<*>> b + a *>> b = biliftA2 (const id) (const id) a b {-# INLINE (*>>) #-} -- | @@ -61,65 +67,237 @@ -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b -- @ (<<*) :: p a b -> p c d -> p a b - a <<* b = bimap const const <<$>> a <<*>> b + a <<* b = biliftA2 const const a b {-# INLINE (<<*) #-} (<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d (<<**>>) = biliftA2 (flip id) (flip id) {-# INLINE (<<**>>) #-} --- | Lift binary functions -biliftA2 :: Biapplicative w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f -biliftA2 f g a b = bimap f g <<$>> a <<*>> b -{-# INLINE biliftA2 #-} -- | Lift ternary functions biliftA3 :: Biapplicative w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h -biliftA3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c +biliftA3 f g a b c = biliftA2 f g a b <<*>> c {-# INLINE biliftA3 #-} +-- | Traverse a 'Traversable' container in a 'Biapplicative'. +-- +-- 'traverseBia' satisfies the following properties: +-- +-- [/Pairing/] +-- +-- @'traverseBia' (,) t = (t, t)@ +-- +-- [/Composition/] +-- +-- @'traverseBia' ('Data.Bifunctor.Biff.Biff' . 'bimap' g h . f) = 'Data.Bifunctor.Biff.Biff' . 'bimap' ('traverse' g) ('traverse' h) . 'traverseBia' f@ +-- +-- @'traverseBia' ('Data.Bifunctor.Tannen.Tannen' . 'fmap' f . g) = 'Data.Bifunctor.Tannen.Tannen' . 'fmap' ('traverseBia' f) . 'traverse' g@ +-- +-- [/Naturality/] +-- +-- @ t . 'traverseBia' f = 'traverseBia' (t . f) @ +-- +-- for every biapplicative transformation @t@. +-- +-- A /biapplicative transformation/ from a 'Biapplicative' @P@ to a 'Biapplicative' @Q@ +-- is a function +-- +-- @t :: P a b -> Q a b@ +-- +-- preserving the 'Biapplicative' operations. That is, +-- +-- * @t ('bipure' x y) = 'bipure' x y@ +-- +-- * @t (x '<<*>>' y) = t x '<<*>>' t y@ +-- +-- === Performance note +-- +-- 'traverseBia' is fairly efficient, and uses compiler rewrite rules +-- to be even more efficient for a few important types like @[]@. However, +-- if performance is critical, you might consider writing a container-specific +-- implementation. +traverseBia :: (Traversable t, Biapplicative p) + => (a -> p b c) -> t a -> p (t b) (t c) +traverseBia = inline (traverseBiaWith traverse) +-- We explicitly inline traverseBiaWith because it seems likely to help +-- specialization. I'm not much of an expert at the inlining business, +-- so I won't mind if someone else decides to do this differently. + +-- We use a staged INLINABLE so we can rewrite traverseBia to specialized +-- versions for a few important types. +{-# INLINABLE [1] traverseBia #-} + +-- | Perform all the 'Biapplicative' actions in a 'Traversable' container +-- and produce a container with all the results. +-- +-- @ +-- sequenceBia = 'traverseBia' id +-- @ +sequenceBia :: (Traversable t, Biapplicative p) + => t (p b c) -> p (t b) (t c) +sequenceBia = inline (traverseBia id) +{-# INLINABLE sequenceBia #-} + +-- | A version of 'traverseBia' that doesn't care how the traversal is +-- done. +-- +-- @ +-- 'traverseBia' = traverseBiaWith traverse +-- @ +traverseBiaWith :: forall p a b c s t. Biapplicative p + => (forall f x. Applicative f => (a -> f x) -> s -> f (t x)) + -> (a -> p b c) -> s -> p (t b) (t c) +traverseBiaWith trav p s = smash p (trav One s) +{-# INLINABLE traverseBiaWith #-} + +smash :: forall p t a b c. Biapplicative p + => (a -> p b c) + -> (forall x. Mag a x (t x)) + -> p (t b) (t c) +smash p m = go m m + where + go :: forall x y. Mag a b x -> Mag a c y -> p x y + go (Pure t) (Pure u) = bipure t u + go (Map f x) (Map g y) = bimap f g (go x y) + go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys +#if MIN_VERSION_base(4,10,0) + go (LiftA2 f xs ys) (LiftA2 g zs ws) = biliftA2 f g (go xs zs) (go ys ws) +#endif + go (One x) (One _) = p x + go _ _ = impossibleError +{-# INLINABLE smash #-} + +-- Let's not end up with a bunch of CallStack junk in the smash +-- unfolding. +impossibleError :: a +impossibleError = error "Impossible: the arguments are always the same." + +-- This is used to reify a traversal for 'traverseBia'. It's a somewhat +-- bogus 'Functor' and 'Applicative' closely related to 'Magma' from the +-- @lens@ package. Valid traversals don't use (<$), (<*), or (*>), so +-- we leave them out. We offer all the rest of the Functor and Applicative +-- operations to improve performance: we generally want to keep the structure +-- as small as possible. We might even consider using RULES to widen lifts +-- when we can: +-- +-- liftA2 f x y <*> z ==> liftA3 f x y z, +-- +-- etc., up to the pointer tagging limit. But we do need to be careful. I don't +-- *think* GHC will ever inline the traversal into the go function (because that +-- would duplicate work), but if it did, and if different RULES fired for the +-- two copies, everything would break horribly. +-- +-- Note: if it's necessary for some reason, we *could* relax GADTs to +-- ExistentialQuantification by changing the type of One to +-- +-- One :: (b -> c) -> a -> Mag a b c +-- +-- where the function will always end up being id. But we allocate a *lot* +-- of One constructors, so this would definitely be bad for performance. +data Mag a b t where + Pure :: t -> Mag a b t + Map :: (x -> t) -> Mag a b x -> Mag a b t + Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u +#if MIN_VERSION_base(4,10,0) + LiftA2 :: (t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v +#endif + One :: a -> Mag a b b + +instance Functor (Mag a b) where + fmap = Map + +instance Applicative (Mag a b) where + pure = Pure + (<*>) = Ap +#if MIN_VERSION_base(4,10,0) + liftA2 = LiftA2 +#endif + +-- Rewrite rules for traversing a few important types. These avoid the overhead +-- of allocating and matching on a Mag. +{-# RULES +"traverseBia/list" forall f t. traverseBia f t = traverseBiaList f t +"traverseBia/Maybe" forall f t. traverseBia f t = traverseBiaMaybe f t +"traverseBia/Either" forall f t. traverseBia f t = traverseBiaEither f t +"traverseBia/Identity" forall f t. traverseBia f t = traverseBiaIdentity f t +"traverseBia/Const" forall f t. traverseBia f t = traverseBiaConst f t +"traverseBia/Pair" forall f t. traverseBia f t = traverseBiaPair f t + #-} + +traverseBiaList :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c] +traverseBiaList f = foldr go (bipure [] []) + where + go x r = biliftA2 (:) (:) (f x) r + +traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c) +traverseBiaMaybe _f Nothing = bipure Nothing Nothing +traverseBiaMaybe f (Just x) = bimap Just Just (f x) + +traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c) +traverseBiaEither f (Right x) = bimap Right Right (f x) +traverseBiaEither _f (Left (e :: e)) = bipure m m + where + m :: Either e x + m = Left e + +traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c) +traverseBiaIdentity f (Identity x) = bimap Identity Identity (f x) + +traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c) +traverseBiaConst _f (Const x) = bipure (Const x) (Const x) + +traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c) +traverseBiaPair f (x,y) = bimap ((,) x) ((,) x) (f y) + +---------------------------------------------- +-- +-- Instances + instance Biapplicative (,) where bipure = (,) {-# INLINE bipure #-} - (f, g) <<*>> (a, b) = (f a, g b) + ~(f, g) <<*>> ~(a, b) = (f a, g b) {-# INLINE (<<*>>) #-} + biliftA2 f g ~(x, y) ~(a, b) = (f x a, g y b) + {-# INLINE biliftA2 #-} -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Biapplicative Arg where bipure = Arg {-# INLINE bipure #-} Arg f g <<*>> Arg a b = Arg (f a) (g b) {-# INLINE (<<*>>) #-} -#endif + biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b) + {-# INLINE biliftA2 #-} instance Monoid x => Biapplicative ((,,) x) where bipure = (,,) mempty {-# INLINE bipure #-} - (x, f, g) <<*>> (x', a, b) = (mappend x x', f a, g b) + ~(x, f, g) <<*>> ~(x', a, b) = (mappend x x', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y) => Biapplicative ((,,,) x y) where bipure = (,,,) mempty mempty {-# INLINE bipure #-} - (x, y, f, g) <<*>> (x', y', a, b) = (mappend x x', mappend y y', f a, g b) + ~(x, y, f, g) <<*>> ~(x', y', a, b) = (mappend x x', mappend y y', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z) => Biapplicative ((,,,,) x y z) where bipure = (,,,,) mempty mempty mempty {-# INLINE bipure #-} - (x, y, z, f, g) <<*>> (x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b) + ~(x, y, z, f, g) <<*>> ~(x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z, Monoid w) => Biapplicative ((,,,,,) x y z w) where bipure = (,,,,,) mempty mempty mempty mempty {-# INLINE bipure #-} - (x, y, z, w, f, g) <<*>> (x', y', z', w', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', f a, g b) + ~(x, y, z, w, f, g) <<*>> ~(x', y', z', w', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Biapplicative ((,,,,,,) x y z w v) where bipure = (,,,,,,) mempty mempty mempty mempty mempty {-# INLINE bipure #-} - (x, y, z, w, v, f, g) <<*>> (x', y', z', w', v', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', mappend v v', f a, g b) + ~(x, y, z, w, v, f, g) <<*>> ~(x', y', z', w', v', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', mappend v v', f a, g b) {-# INLINE (<<*>>) #-} #ifdef MIN_VERSION_tagged diff --git a/src/Data/Bifoldable.hs b/src/Data/Bifoldable.hs deleted file mode 100644 --- a/src/Data/Bifoldable.hs +++ /dev/null @@ -1,422 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -#ifndef MIN_VERSION_semigroups -#define MIN_VERSION_semigroups(x,y,z) 0 -#endif ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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,9,0) || MIN_VERSION_semigroups(0,16,2) -import Data.Semigroup (Arg(..)) -#endif - -#ifdef MIN_VERSION_tagged -import Data.Tagged -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (K1(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -import Data.Typeable -#endif - --- | Minimal definition either 'bifoldr' or 'bifoldMap' - --- | 'Bifoldable' identifies foldable structures with two different varieties of --- elements. 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) --- --- When defining more than the minimal set of definitions, 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 --- @ -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@ - bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c - bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z - {-# INLINE bifoldl #-} - -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL bifoldr | bifoldMap #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -deriving instance Typeable Bifoldable -#endif - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) -instance Bifoldable Arg where - bifoldMap f g (Arg a b) = f a `mappend` g b -#endif - -instance Bifoldable (,) where - bifoldMap f g ~(a, b) = f a `mappend` g b - {-# INLINE bifoldMap #-} - -instance Bifoldable Const where - bifoldMap f _ (Const a) = f a - {-# INLINE bifoldMap #-} - -instance Bifoldable Constant where - bifoldMap f _ (Constant a) = f a - {-# INLINE bifoldMap #-} - -#if __GLASGOW_HASKELL__ >= 702 -instance Bifoldable (K1 i) where - bifoldMap f _ (K1 c) = f c - {-# INLINE bifoldMap #-} -#endif - -instance Bifoldable ((,,) x) where - bifoldMap f g ~(_,a,b) = f a `mappend` g b - {-# INLINE bifoldMap #-} - -instance Bifoldable ((,,,) x y) where - bifoldMap f g ~(_,_,a,b) = f a `mappend` g b - {-# INLINE bifoldMap #-} - -instance Bifoldable ((,,,,) x y z) where - bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b - {-# INLINE bifoldMap #-} - -instance Bifoldable ((,,,,,) x y z w) where - bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b - {-# INLINE bifoldMap #-} - -instance Bifoldable ((,,,,,,) x y z w v) where - bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b - {-# INLINE bifoldMap #-} - -#ifdef MIN_VERSION_tagged -instance Bifoldable Tagged where - bifoldMap _ g (Tagged b) = g b - {-# INLINE bifoldMap #-} -#endif - -instance Bifoldable Either where - bifoldMap f _ (Left a) = f a - bifoldMap _ g (Right b) = g b - {-# INLINE bifoldMap #-} - --- | As 'bifoldr', but strict in the result of the reduction functions at each --- step. -bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c -bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where - f' k x z = k $! f x z - g' k x z = k $! g x z -{-# INLINE bifoldr' #-} - --- | A variant of 'bifoldr' that has no base case, --- and thus may only be applied to non-empty structures. -bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a -bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure") - (bifoldr mbf mbf Nothing xs) - where - mbf x m = Just (case m of - Nothing -> x - Just y -> f x y) -{-# INLINE bifoldr1 #-} - --- | Right associative monadic bifold over a structure. -bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c -bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where - f' k x z = f x z >>= k - g' k x z = g x z >>= k -{-# INLINE bifoldrM #-} - --- | As 'bifoldl', but strict in the result of the reductionf unctions at each --- step. -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 #-} - --- | As 'Data.Bitraversable.bitraverse', but ignores the results of the --- functions, merely performing the "actions". -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. -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_ #-} - --- | As 'Data.Bitraversable.bisequence', but ignores the results of the actions. -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 in order. -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 #-} diff --git a/src/Data/Bifunctor/Biap.hs b/src/Data/Bifunctor/Biap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Biap.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- This module uses GND +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2008-2016 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Bifunctor.Biap + ( Biap(..) + ) where + +import Control.Applicative +import Control.Monad +import qualified Control.Monad.Fail as Fail (MonadFail) +import Data.Biapplicative +import Data.Bifoldable +import Data.Bitraversable +import Data.Functor.Classes +import qualified Data.Semigroup as S +import GHC.Generics + +-- | Pointwise lifting of a class over two arguments, using +-- 'Biapplicative'. +-- +-- Classes that can be lifted include 'Monoid', 'Num' and +-- 'Bounded'. Each method of those classes can be defined as lifting +-- themselves over each argument of 'Biapplicative'. +-- +-- @ +-- mempty = bipure mempty mempty +-- minBound = bipure minBound minBound +-- maxBound = bipure maxBound maxBound +-- fromInteger n = bipure (fromInteger n) (fromInteger n) +-- +-- negate = bimap negate negate +-- +-- (+) = biliftA2 (+) (+) +-- (<>) = biliftA2 (<>) (<>) +-- @ +-- +-- 'Biap' is to 'Biapplicative' as 'Data.Monoid.Ap' is to +-- 'Applicative'. +-- +-- 'Biap' can be used with @DerivingVia@ to derive a numeric instance +-- for pairs: +-- +-- @ +-- newtype Numpair a = Np (a, a) +-- deriving (S.Semigroup, Monoid, Num, Bounded) +-- via Biap (,) a a +-- @ +-- +newtype Biap bi a b = Biap { getBiap :: bi a b } + deriving ( Eq + , Ord + , Show + , Read + , Enum + , Functor + , Foldable + , Traversable + , Alternative + , Applicative + , Generic + , Generic1 + , Monad + , Fail.MonadFail + , MonadPlus + , Eq1 + , Ord1 + , Bifunctor + , Biapplicative + , Bifoldable + , Eq2 + , Ord2 + ) + +instance Bitraversable bi => Bitraversable (Biap bi) where + bitraverse f g (Biap as) = Biap <$> bitraverse f g as + +instance (Biapplicative bi, S.Semigroup a, S.Semigroup b) => S.Semigroup (Biap bi a b) where + (<>) = biliftA2 (S.<>) (S.<>) + +instance (Biapplicative bi, Monoid a, Monoid b) => Monoid (Biap bi a b) where + mempty = bipure mempty mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = biliftA2 mappend mappend +#endif + +instance (Biapplicative bi, Bounded a, Bounded b) => Bounded (Biap bi a b) where + minBound = bipure minBound minBound + maxBound = bipure maxBound maxBound + +instance (Biapplicative bi, Num a, Num b) => Num (Biap bi a b) where + (+) = biliftA2 (+) (+) + (*) = biliftA2 (*) (*) + + negate = bimap negate negate + abs = bimap abs abs + signum = bimap signum signum + + fromInteger n = bipure (fromInteger n) (fromInteger n) diff --git a/src/Data/Bifunctor/Biff.hs b/src/Data/Bifunctor/Biff.hs --- a/src/Data/Bifunctor/Biff.hs +++ b/src/Data/Bifunctor/Biff.hs @@ -1,19 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett @@ -28,64 +21,50 @@ ( Biff(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) +import Data.Bifunctor.Swap (Swap (..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Foldable1 (Foldable1(..)) +import Data.Functor.Classes import GHC.Generics -#endif -- | Compose two 'Functor's on the inside of a 'Bifunctor'. newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) } - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Typeable -#endif - ) -#if __GLASGOW_HASKELL__ >= 702 -# if __GLASGOW_HASKELL__ >= 708 + deriving (Eq, Ord, Show, Read, Generic) deriving instance Functor (p (f a)) => Generic1 (Biff p f g a) -# else -data BiffMetaData -data BiffMetaCons -data BiffMetaSel -instance Datatype BiffMetaData where - datatypeName = const "Biff" - moduleName = const "Data.Bifunctor.Biff" +instance (Eq2 p, Eq1 f, Eq1 g, Eq a) => Eq1 (Biff p f g a) where + liftEq = liftEq2 (==) +instance (Eq2 p, Eq1 f, Eq1 g) => Eq2 (Biff p f g) where + liftEq2 f g (Biff x) (Biff y) = liftEq2 (liftEq f) (liftEq g) x y -instance Constructor BiffMetaCons where - conName = const "Biff" - conIsRecord = const True +instance (Ord2 p, Ord1 f, Ord1 g, Ord a) => Ord1 (Biff p f g a) where + liftCompare = liftCompare2 compare +instance (Ord2 p, Ord1 f, Ord1 g) => Ord2 (Biff p f g) where + liftCompare2 f g (Biff x) (Biff y) = liftCompare2 (liftCompare f) (liftCompare g) x y -instance Selector BiffMetaSel where - selName = const "runBiff" +instance (Read2 p, Read1 f, Read1 g, Read a) => Read1 (Biff p f g a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Read2 p, Read1 f, Read1 g) => Read2 (Biff p f g) where + liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do + ("Biff", s1) <- lex s0 + ("{", s2) <- lex s1 + ("runBiff", s3) <- lex s2 + (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1) + (liftReadsPrec rp2 rl2) (liftReadList rp2 rl2) 0 s3 + ("}", s5) <- lex s4 + return (Biff x, s5) -instance Functor (p (f a)) => Generic1 (Biff p f g a) where - type Rep1 (Biff p f g a) = D1 BiffMetaData (C1 BiffMetaCons - (S1 BiffMetaSel (p (f a) :.: Rec1 g))) - from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runBiff - to1 = Biff . fmap unRec1 . unComp1 . unM1 . unM1 . unM1 -# endif -#endif +instance (Show2 p, Show1 f, Show1 g, Show a) => Show1 (Biff p f g a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Show2 p, Show1 f, Show1 g) => Show2 (Biff p f g) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (Biff x) = showParen (p > 10) $ + showString "Biff {runBiff = " + . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) + (liftShowsPrec sp2 sl2) (liftShowList sp2 sl2) 0 x + . showChar '}' instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where first f = Biff . first (fmap f) . runBiff @@ -114,6 +93,10 @@ bifoldMap f g = bifoldMap (foldMap f) (foldMap g) . runBiff {-# INLINE bifoldMap #-} +instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where + bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff + {-# INLINE bifoldMap1 #-} + instance (Bitraversable p, Traversable g) => Traversable (Biff p f g a) where traverse f = fmap Biff . bitraverse pure (traverse f) . runBiff {-# INLINE traverse #-} @@ -121,3 +104,7 @@ instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (Biff p f g) where bitraverse f g = fmap Biff . bitraverse (traverse f) (traverse g) . runBiff {-# INLINE bitraverse #-} + +-- | @since 5.6.1 +instance (f ~ g, Functor f, Swap p) => Swap (Biff p f g) where + swap = Biff . swap . runBiff diff --git a/src/Data/Bifunctor/Clown.hs b/src/Data/Bifunctor/Clown.hs --- a/src/Data/Bifunctor/Clown.hs +++ b/src/Data/Bifunctor/Clown.hs @@ -1,15 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -27,66 +20,68 @@ ( Clown(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Foldable1 (Foldable1(..)) +import Data.Functor.Classes import GHC.Generics -#endif -- | Make a 'Functor' over the first argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Clown f a b = Clown { runClown :: f a } - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Generic1 - , Typeable -#endif - ) + deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data ClownMetaData -data ClownMetaCons -data ClownMetaSel +instance (Eq1 f, Eq a) => Eq1 (Clown f a) where + liftEq = liftEq2 (==) +instance Eq1 f => Eq2 (Clown f) where + liftEq2 f _ = eqClown (liftEq f) -instance Datatype ClownMetaData where - datatypeName _ = "Clown" - moduleName _ = "Data.Bifunctor.Clown" +instance (Ord1 f, Ord a) => Ord1 (Clown f a) where + liftCompare = liftCompare2 compare +instance Ord1 f => Ord2 (Clown f) where + liftCompare2 f _ = compareClown (liftCompare f) -instance Constructor ClownMetaCons where - conName _ = "Clown" - conIsRecord _ = True +instance (Read1 f, Read a) => Read1 (Clown f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance Read1 f => Read2 (Clown f) where + liftReadsPrec2 rp1 rl1 _ _ = readsPrecClown (liftReadsPrec rp1 rl1) -instance Selector ClownMetaSel where - selName _ = "runClown" +instance (Show1 f, Show a) => Show1 (Clown f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show1 f => Show2 (Clown f) where + liftShowsPrec2 sp1 sl1 _ _ = showsPrecClown (liftShowsPrec sp1 sl1) -instance Generic1 (Clown f a) where - type Rep1 (Clown f a) = D1 ClownMetaData (C1 ClownMetaCons - (S1 ClownMetaSel (Rec0 (f a)))) - from1 = M1 . M1 . M1 . K1 . runClown - to1 = Clown . unK1 . unM1 . unM1 . unM1 -#endif +eqClown :: (f a1 -> f a2 -> Bool) + -> Clown f a1 b1 -> Clown f a2 b2 -> Bool +eqClown eqA (Clown x) (Clown y) = eqA x y +compareClown :: (f a1 -> f a2 -> Ordering) + -> Clown f a1 b1 -> Clown f a2 b2 -> Ordering +compareClown compareA (Clown x) (Clown y) = compareA x y + +readsPrecClown :: (Int -> ReadS (f a)) + -> Int -> ReadS (Clown f a b) +readsPrecClown rpA p = + readParen (p > 10) $ \s0 -> do + ("Clown", s1) <- lex s0 + ("{", s2) <- lex s1 + ("runClown", s3) <- lex s2 + (x, s4) <- rpA 0 s3 + ("}", s5) <- lex s4 + return (Clown x, s5) + +showsPrecClown :: (Int -> f a -> ShowS) + -> Int -> Clown f a b -> ShowS +showsPrecClown spA p (Clown x) = + showParen (p > 10) $ + showString "Clown {runClown = " + . spA 0 x + . showChar '}' + instance Functor f => Bifunctor (Clown f) where first f = Clown . fmap f . runClown {-# INLINE first #-} @@ -109,6 +104,10 @@ instance Foldable f => Bifoldable (Clown f) where bifoldMap f _ = foldMap f . runClown {-# INLINE bifoldMap #-} + +instance Foldable1 f => Bifoldable1 (Clown f) where + bifoldMap1 f _ = foldMap1 f . runClown + {-# INLINE bifoldMap1 #-} instance Foldable (Clown f a) where foldMap _ = mempty diff --git a/src/Data/Bifunctor/Fix.hs b/src/Data/Bifunctor/Fix.hs --- a/src/Data/Bifunctor/Fix.hs +++ b/src/Data/Bifunctor/Fix.hs @@ -1,17 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - ----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Fix @@ -27,44 +20,43 @@ ( Fix(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Functor.Classes import GHC.Generics -#endif -- | Greatest fixpoint of a 'Bifunctor' (a 'Functor' over the first argument with zipping). newtype Fix p a = In { out :: p (Fix p a) a } - deriving - ( -#if __GLASGOW_HASKELL__ >= 702 - Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Typeable -#endif - ) + deriving Generic deriving instance Eq (p (Fix p a) a) => Eq (Fix p a) deriving instance Ord (p (Fix p a) a) => Ord (Fix p a) deriving instance Show (p (Fix p a) a) => Show (Fix p a) deriving instance Read (p (Fix p a) a) => Read (Fix p a) +instance Eq2 p => Eq1 (Fix p) where + liftEq f (In x) (In y) = liftEq2 (liftEq f) f x y + +instance Ord2 p => Ord1 (Fix p) where + liftCompare f (In x) (In y) = liftCompare2 (liftCompare f) f x y + +instance Read2 p => Read1 (Fix p) where + liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do + ("In", s1) <- lex s0 + ("{", s2) <- lex s1 + ("out", s3) <- lex s2 + (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1) + rp1 rl1 0 s3 + ("}", s5) <- lex s4 + return (In x, s5) + +instance Show2 p => Show1 (Fix p) where + liftShowsPrec sp1 sl1 p (In x) = showParen (p > 10) $ + showString "In {out = " + . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) + sp1 sl1 0 x + . showChar '}' instance Bifunctor p => Functor (Fix p) where fmap f (In p) = In (bimap (fmap f) f p) diff --git a/src/Data/Bifunctor/Flip.hs b/src/Data/Bifunctor/Flip.hs --- a/src/Data/Bifunctor/Flip.hs +++ b/src/Data/Bifunctor/Flip.hs @@ -1,13 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -24,40 +17,49 @@ ( Flip(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bifunctor.Functor +import Data.Bifunctor.Swap (Swap (..)) +import Data.Bifunctor.Assoc (Assoc (..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Functor.Classes import GHC.Generics -#endif -- | Make a 'Bifunctor' flipping the arguments of a 'Bifunctor'. newtype Flip p a b = Flip { runFlip :: p b a } - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Typeable -#endif - ) + deriving (Eq, Ord, Show, Read, Generic) +instance (Eq2 p, Eq a) => Eq1 (Flip p a) where + liftEq = liftEq2 (==) +instance Eq2 p => Eq2 (Flip p) where + liftEq2 f g (Flip x) (Flip y) = liftEq2 g f x y + +instance (Ord2 p, Ord a) => Ord1 (Flip p a) where + liftCompare = liftCompare2 compare +instance Ord2 p => Ord2 (Flip p) where + liftCompare2 f g (Flip x) (Flip y) = liftCompare2 g f x y + +instance (Read2 p, Read a) => Read1 (Flip p a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance Read2 p => Read2 (Flip p) where + liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do + ("Flip", s1) <- lex s0 + ("{", s2) <- lex s1 + ("runFlip", s3) <- lex s2 + (x, s4) <- liftReadsPrec2 rp2 rl2 rp1 rl1 0 s3 + ("}", s5) <- lex s4 + return (Flip x, s5) + +instance (Show2 p, Show a) => Show1 (Flip p a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show2 p => Show2 (Flip p) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (Flip x) = showParen (p > 10) $ + showString "Flip {runFlip = " + . liftShowsPrec2 sp2 sl2 sp1 sl1 0 x + . showChar '}' + instance Bifunctor p => Bifunctor (Flip p) where first f = Flip . second f . runFlip {-# INLINE first #-} @@ -81,6 +83,10 @@ bifoldMap f g = bifoldMap g f . runFlip {-# INLINE bifoldMap #-} +instance Bifoldable1 p => Bifoldable1 (Flip p) where + bifoldMap1 f g = bifoldMap1 g f . runFlip + {-# INLINE bifoldMap1 #-} + instance Bifoldable p => Foldable (Flip p a) where foldMap f = bifoldMap f (const mempty) . runFlip {-# INLINE foldMap #-} @@ -95,3 +101,12 @@ instance BifunctorFunctor Flip where bifmap f (Flip p) = Flip (f p) + +-- | @since 5.6.1 +instance Assoc p => Assoc (Flip p) where + assoc = Flip . first Flip . unassoc . second runFlip . runFlip + unassoc = Flip . second Flip . assoc . first runFlip . runFlip + +-- | @since 5.6.1 +instance Swap p => Swap (Flip p) where + swap = Flip . swap . runFlip diff --git a/src/Data/Bifunctor/Functor.hs b/src/Data/Bifunctor/Functor.hs --- a/src/Data/Bifunctor/Functor.hs +++ b/src/Data/Bifunctor/Functor.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - module Data.Bifunctor.Functor ( (:->) , BifunctorFunctor(..) @@ -28,9 +25,7 @@ bibind f = bijoin . bifmap f bijoin :: t (t p) :-> t p bijoin = bibind id -#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bireturn, (bibind | bijoin) #-} -#endif biliftM :: BifunctorMonad t => (p :-> q) -> t p :-> t q biliftM f = bibind (bireturn . f) @@ -42,9 +37,7 @@ biextend f = bifmap f . biduplicate biduplicate :: t p :-> t (t p) biduplicate = biextend id -#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL biextract, (biextend | biduplicate) #-} -#endif biliftW :: BifunctorComonad t => (p :-> q) -> t p :-> t q biliftW f = biextend (f . biextract) diff --git a/src/Data/Bifunctor/Join.hs b/src/Data/Bifunctor/Join.hs --- a/src/Data/Bifunctor/Join.hs +++ b/src/Data/Bifunctor/Join.hs @@ -1,17 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett @@ -26,44 +19,44 @@ ( Join(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Foldable1 (Foldable1(..)) +import Data.Functor.Classes import GHC.Generics -#endif -- | Make a 'Functor' over both arguments of a 'Bifunctor'. newtype Join p a = Join { runJoin :: p a a } - deriving - ( -#if __GLASGOW_HASKELL__ >= 702 - Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Typeable -#endif - ) + deriving Generic deriving instance Eq (p a a) => Eq (Join p a) deriving instance Ord (p a a) => Ord (Join p a) deriving instance Show (p a a) => Show (Join p a) deriving instance Read (p a a) => Read (Join p a) +instance Eq2 p => Eq1 (Join p) where + liftEq f (Join x) (Join y) = liftEq2 f f x y + +instance Ord2 p => Ord1 (Join p) where + liftCompare f (Join x) (Join y) = liftCompare2 f f x y + +instance Read2 p => Read1 (Join p) where + liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do + ("Join", s1) <- lex s0 + ("{", s2) <- lex s1 + ("runJoin", s3) <- lex s2 + (x, s4) <- liftReadsPrec2 rp1 rl1 rp1 rl1 0 s3 + ("}", s5) <- lex s4 + return (Join x, s5) + +instance Show2 p => Show1 (Join p) where + liftShowsPrec sp1 sl1 p (Join x) = showParen (p > 10) $ + showString "Join {runJoin = " + . liftShowsPrec2 sp1 sl1 sp1 sl1 0 x + . showChar '}' + instance Bifunctor p => Functor (Join p) where fmap f (Join a) = Join (bimap f f a) {-# INLINE fmap #-} @@ -81,6 +74,10 @@ instance Bifoldable p => Foldable (Join p) where foldMap f (Join a) = bifoldMap f f a {-# INLINE foldMap #-} + +instance Bifoldable1 p => Foldable1 (Join p) where + foldMap1 f (Join a) = bifoldMap1 f f a + {-# INLINE foldMap1 #-} instance Bitraversable p => Traversable (Join p) where traverse f (Join a) = fmap Join (bitraverse f f a) diff --git a/src/Data/Bifunctor/Joker.hs b/src/Data/Bifunctor/Joker.hs --- a/src/Data/Bifunctor/Joker.hs +++ b/src/Data/Bifunctor/Joker.hs @@ -1,15 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -27,65 +20,68 @@ ( Joker(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Foldable1 (Foldable1(..)) +import Data.Functor.Classes import GHC.Generics -#endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Joker g a b = Joker { runJoker :: g b } - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Generic1 - , Typeable -#endif - ) + deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data JokerMetaData -data JokerMetaCons -data JokerMetaSel +instance Eq1 g => Eq1 (Joker g a) where + liftEq g = eqJoker (liftEq g) +instance Eq1 g => Eq2 (Joker g) where + liftEq2 _ g = eqJoker (liftEq g) -instance Datatype JokerMetaData where - datatypeName _ = "Joker" - moduleName _ = "Data.Bifunctor.Joker" +instance Ord1 g => Ord1 (Joker g a) where + liftCompare g = compareJoker (liftCompare g) +instance Ord1 g => Ord2 (Joker g) where + liftCompare2 _ g = compareJoker (liftCompare g) -instance Constructor JokerMetaCons where - conName _ = "Joker" - conIsRecord _ = True +instance Read1 g => Read1 (Joker g a) where + liftReadsPrec rp rl = readsPrecJoker (liftReadsPrec rp rl) +instance Read1 g => Read2 (Joker g) where + liftReadsPrec2 _ _ rp2 rl2 = readsPrecJoker (liftReadsPrec rp2 rl2) -instance Selector JokerMetaSel where - selName _ = "runJoker" +instance Show1 g => Show1 (Joker g a) where + liftShowsPrec sp sl = showsPrecJoker (liftShowsPrec sp sl) +instance Show1 g => Show2 (Joker g) where + liftShowsPrec2 _ _ sp2 sl2 = showsPrecJoker (liftShowsPrec sp2 sl2) -instance Generic1 (Joker g a) where - type Rep1 (Joker g a) = D1 JokerMetaData (C1 JokerMetaCons - (S1 JokerMetaSel (Rec1 g))) - from1 = M1 . M1 . M1 . Rec1 . runJoker - to1 = Joker . unRec1 . unM1 . unM1 . unM1 -#endif +eqJoker :: (g b1 -> g b2 -> Bool) + -> Joker g a1 b1 -> Joker g a2 b2 -> Bool +eqJoker eqB (Joker x) (Joker y) = eqB x y +compareJoker :: (g b1 -> g b2 -> Ordering) + -> Joker g a1 b1 -> Joker g a2 b2 -> Ordering +compareJoker compareB (Joker x) (Joker y) = compareB x y + +readsPrecJoker :: (Int -> ReadS (g b)) + -> Int -> ReadS (Joker g a b) +readsPrecJoker rpB p = + readParen (p > 10) $ \s0 -> do + ("Joker", s1) <- lex s0 + ("{", s2) <- lex s1 + ("runJoker", s3) <- lex s2 + (x, s4) <- rpB 0 s3 + ("}", s5) <- lex s4 + return (Joker x, s5) + +showsPrecJoker :: (Int -> g b -> ShowS) + -> Int -> Joker g a b -> ShowS +showsPrecJoker spB p (Joker x) = + showParen (p > 10) $ + showString "Joker {runJoker = " + . spB 0 x + . showChar '}' + instance Functor g => Bifunctor (Joker g) where first _ = Joker . runJoker {-# INLINE first #-} @@ -109,9 +105,17 @@ bifoldMap _ g = foldMap g . runJoker {-# INLINE bifoldMap #-} +instance Foldable1 g => Bifoldable1 (Joker g) where + bifoldMap1 _ g = foldMap1 g . runJoker + {-# INLINE bifoldMap1 #-} + instance Foldable g => Foldable (Joker g a) where foldMap g = foldMap g . runJoker {-# INLINE foldMap #-} + +instance Foldable1 g => Foldable1 (Joker g a) where + foldMap1 g = foldMap1 g . runJoker + {-# INLINE foldMap1 #-} instance Traversable g => Bitraversable (Joker g) where bitraverse _ g = fmap Joker . traverse g . runJoker diff --git a/src/Data/Bifunctor/Product.hs b/src/Data/Bifunctor/Product.hs --- a/src/Data/Bifunctor/Product.hs +++ b/src/Data/Bifunctor/Product.hs @@ -1,15 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -26,57 +24,54 @@ ( Product(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - +import qualified Control.Arrow as A +import Control.Category import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bifunctor.Functor +import Data.Bifunctor.Swap (Swap (..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid hiding (Product) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Functor.Classes +import qualified Data.Semigroup as S import GHC.Generics -#endif +import Prelude hiding ((.),id) + -- | Form the product of two bifunctors data Product f g a b = Pair (f a b) (g a b) - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Generic1 - , Typeable -#endif - ) + deriving (Eq, Ord, Show, Read, Generic, Generic1) +deriving instance (Functor (f a), Functor (g a)) => Functor (Product f g a) +deriving instance (Foldable (f a), Foldable (g a)) => Foldable (Product f g a) +deriving instance (Traversable (f a), Traversable (g a)) => Traversable (Product f g a) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data ProductMetaData -data ProductMetaCons +instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Product f g a) where + liftEq = liftEq2 (==) +instance (Eq2 f, Eq2 g) => Eq2 (Product f g) where + liftEq2 f g (Pair x1 y1) (Pair x2 y2) = + liftEq2 f g x1 x2 && liftEq2 f g y1 y2 -instance Datatype ProductMetaData where - datatypeName _ = "Product" - moduleName _ = "Data.Bifunctor.Product" +instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Product f g a) where + liftCompare = liftCompare2 compare +instance (Ord2 f, Ord2 g) => Ord2 (Product f g) where + liftCompare2 f g (Pair x1 y1) (Pair x2 y2) = + liftCompare2 f g x1 x2 `mappend` liftCompare2 f g y1 y2 -instance Constructor ProductMetaCons where - conName _ = "Pair" +instance (Read2 f, Read2 g, Read a) => Read1 (Product f g a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Read2 f, Read2 g) => Read2 (Product f g) where + liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $ + readsBinaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) + (liftReadsPrec2 rp1 rl1 rp2 rl2) + "Pair" Pair -instance Generic1 (Product f g a) where - type Rep1 (Product f g a) = D1 ProductMetaData (C1 ProductMetaCons ((:*:) - (S1 NoSelector (Rec1 (f a))) - (S1 NoSelector (Rec1 (g a))))) - from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) - to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) -#endif +instance (Show2 f, Show2 g, Show a) => Show1 (Product f g a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Show2 f, Show2 g) => Show2 (Product f g) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (Pair x y) = + showsBinaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) + (liftShowsPrec2 sp1 sl1 sp2 sl2) + "Pair" p x y instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where first f (Pair x y) = Pair (first f x) (first f y) @@ -96,6 +91,10 @@ bifoldMap f g (Pair x y) = bifoldMap f g x `mappend` bifoldMap f g y {-# INLINE bifoldMap #-} +instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Product f g) where + bifoldMap1 f g (Pair x y) = bifoldMap1 f g x S.<> bifoldMap1 f g y + {-# INLINE bifoldMap1 #-} + instance (Bitraversable f, Bitraversable g) => Bitraversable (Product f g) where bitraverse f g (Pair x y) = Pair <$> bitraverse f g x <*> bitraverse f g y {-# INLINE bitraverse #-} @@ -107,3 +106,33 @@ biextract (Pair _ q) = q biduplicate pq@(Pair p _) = Pair p pq biextend f pq@(Pair p _) = Pair p (f pq) + +instance (Category p, Category q) => Category (Product p q) where + id = Pair id id + Pair x y . Pair x' y' = Pair (x . x') (y . y') + +instance (A.Arrow p, A.Arrow q) => A.Arrow (Product p q) where + arr f = Pair (A.arr f) (A.arr f) + first (Pair x y) = Pair (A.first x) (A.first y) + second (Pair x y) = Pair (A.second x) (A.second y) + Pair x y *** Pair x' y' = Pair (x A.*** x') (y A.*** y') + Pair x y &&& Pair x' y' = Pair (x A.&&& x') (y A.&&& y') + +instance (A.ArrowChoice p, A.ArrowChoice q) => A.ArrowChoice (Product p q) where + left (Pair x y) = Pair (A.left x) (A.left y) + right (Pair x y) = Pair (A.right x) (A.right y) + Pair x y +++ Pair x' y' = Pair (x A.+++ x') (y A.+++ y') + Pair x y ||| Pair x' y' = Pair (x A.||| x') (y A.||| y') + +instance (A.ArrowLoop p, A.ArrowLoop q) => A.ArrowLoop (Product p q) where + loop (Pair x y) = Pair (A.loop x) (A.loop y) + +instance (A.ArrowZero p, A.ArrowZero q) => A.ArrowZero (Product p q) where + zeroArrow = Pair A.zeroArrow A.zeroArrow + +instance (A.ArrowPlus p, A.ArrowPlus q) => A.ArrowPlus (Product p q) where + Pair x y <+> Pair x' y' = Pair (x A.<+> x') (y A.<+> y') + +-- | @since 5.6.1 +instance (Swap p, Swap q) => Swap (Product p q) where + swap (Pair p q) = Pair (swap p) (swap q) diff --git a/src/Data/Bifunctor/Sum.hs b/src/Data/Bifunctor/Sum.hs --- a/src/Data/Bifunctor/Sum.hs +++ b/src/Data/Bifunctor/Sum.hs @@ -1,67 +1,60 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Data.Bifunctor.Sum where import Data.Bifunctor import Data.Bifunctor.Functor +import Data.Bifunctor.Swap (Swap (..)) import Data.Bifoldable import Data.Bitraversable -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor -#endif -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif -#if __GLASGOW_HASKELL__ >= 702 +import Data.Functor.Classes import GHC.Generics -#endif data Sum p q a b = L2 (p a b) | R2 (q a b) - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Generic1 - , Typeable -#endif - ) - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data SumMetaData -data SumMetaConsL2 -data SumMetaConsR2 + deriving (Eq, Ord, Show, Read, Generic, Generic1) +deriving instance (Functor (f a), Functor (g a)) => Functor (Sum f g a) +deriving instance (Foldable (f a), Foldable (g a)) => Foldable (Sum f g a) +deriving instance (Traversable (f a), Traversable (g a)) => Traversable (Sum f g a) -instance Datatype SumMetaData where - datatypeName _ = "Sum" - moduleName _ = "Data.Bifunctor.Sum" +instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Sum f g a) where + liftEq = liftEq2 (==) +instance (Eq2 f, Eq2 g) => Eq2 (Sum f g) where + liftEq2 f g (L2 x1) (L2 x2) = liftEq2 f g x1 x2 + liftEq2 _ _ (L2 _) (R2 _) = False + liftEq2 _ _ (R2 _) (L2 _) = False + liftEq2 f g (R2 y1) (R2 y2) = liftEq2 f g y1 y2 -instance Constructor SumMetaConsL2 where - conName _ = "L2" +instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Sum f g a) where + liftCompare = liftCompare2 compare +instance (Ord2 f, Ord2 g) => Ord2 (Sum f g) where + liftCompare2 f g (L2 x1) (L2 x2) = liftCompare2 f g x1 x2 + liftCompare2 _ _ (L2 _) (R2 _) = LT + liftCompare2 _ _ (R2 _) (L2 _) = GT + liftCompare2 f g (R2 y1) (R2 y2) = liftCompare2 f g y1 y2 -instance Constructor SumMetaConsR2 where - conName _ = "R2" +instance (Read2 f, Read2 g, Read a) => Read1 (Sum f g a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Read2 f, Read2 g) => Read2 (Sum f g) where + liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $ + readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "L2" L2 `mappend` + readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "R2" R2 -instance Generic1 (Sum p q a) where - type Rep1 (Sum p q a) = D1 SumMetaData ((:+:) - (C1 SumMetaConsL2 (S1 NoSelector (Rec1 (p a)))) - (C1 SumMetaConsR2 (S1 NoSelector (Rec1 (q a))))) - from1 (L2 p) = M1 (L1 (M1 (M1 (Rec1 p)))) - from1 (R2 q) = M1 (R1 (M1 (M1 (Rec1 q)))) - to1 (M1 (L1 (M1 (M1 p)))) = L2 (unRec1 p) - to1 (M1 (R1 (M1 (M1 q)))) = R2 (unRec1 q) -#endif +instance (Show2 f, Show2 g, Show a) => Show1 (Sum f g a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Show2 f, Show2 g) => Show2 (Sum f g) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (L2 x) = + showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "L2" p x + liftShowsPrec2 sp1 sl1 sp2 sl2 p (R2 y) = + showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "R2" p y instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where bimap f g (L2 p) = L2 (bimap f g p) @@ -89,3 +82,8 @@ bijoin (R2 q) = q bibind _ (L2 p) = L2 p bibind f (R2 q) = f q + +-- | @since 5.6.1 +instance (Swap p, Swap q) => Swap (Sum p q) where + swap (L2 p) = L2 (swap p) + swap (R2 q) = R2 (swap q) diff --git a/src/Data/Bifunctor/TH.hs b/src/Data/Bifunctor/TH.hs --- a/src/Data/Bifunctor/TH.hs +++ b/src/Data/Bifunctor/TH.hs @@ -1,1203 +1,1308 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE BangPatterns #-} - -#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 --- Stability : provisional --- Portability : portable --- --- Functions to mechanically derive 'Bifunctor', 'Bifoldable', --- or 'Bitraversable' instances, or to splice their functions directly into --- source code. You need to enable the @TemplateHaskell@ language extension --- in order to use this module. ----------------------------------------------------------------------------- - -module Data.Bifunctor.TH ( - -- * @derive@- functions - -- $derive - -- * @make@- functions - -- $make - -- * 'Bifunctor' - deriveBifunctor - , makeBimap - -- * 'Bifoldable' - , deriveBifoldable - , makeBifold - , makeBifoldMap - , makeBifoldr - , makeBifoldl - -- * 'Bitraversable' - , deriveBitraversable - , makeBitraverse - , makeBisequenceA - , makeBimapM - , makeBisequence - ) where - -import Control.Monad (guard, unless, when, zipWithM) - -import Data.Bifunctor.TH.Internal -import Data.Either (rights) -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) -import Data.Foldable (foldr') -#endif -import Data.List -import qualified Data.Map as Map (fromList, keys, lookup, size) -import Data.Maybe - -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Syntax - -------------------------------------------------------------------------------- --- User-facing API -------------------------------------------------------------------------------- - -{- $derive - -'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically -generate their respective class instances for a given data type, newtype, or data -family instance that has at least two type variable. Examples: - -@ -{-# LANGUAGE TemplateHaskell #-} -import Data.Bifunctor.TH - -data Pair a b = Pair a b -$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ... - -data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b) -$('deriveBifoldable' ''WrapLeftPair) --- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ... -@ - -If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), -the @derive@ functions can be used data family instances (which requires the -@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance -constructor (NOT a data family name!) to a @derive@ function. Note that the -generated code may require the @-XFlexibleInstances@ extension. Example: - -@ -{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} -import Data.Bifunctor.TH - -class AssocClass a b c where - data AssocData a b c -instance AssocClass Int b c where - data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c -$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ... --- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2) -@ - -Note that there are some limitations: - -* The 'Name' argument to a @derive@ function must not be a type synonym. - -* With a @derive@ function, the last two type variables must both be of kind @*@. - Other type variables of kind @* -> *@ are assumed to require a 'Functor', - 'Foldable', or 'Traversable' constraint (depending on which @derive@ function is - used), and other type variables of kind @* -> * -> *@ are assumed to require an - 'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type - doesn't meet these assumptions, use a @make@ function. - -* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@ - extensions, a constraint cannot mention either of the last two type variables. For - example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot - have a derived 'Bifunctor' instance. - -* If either of the last two type variables is used within a constructor argument's - type, it must only be used in the last two type arguments. For example, - @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance, - but @data Illegal a b = Illegal (a, b, a, b)@ cannot. - -* Data family instances must be able to eta-reduce the last two type variables. In other - words, if you have a instance of the form: - - @ - data family Family a1 ... an t1 t2 - data instance Family e1 ... e2 v1 v2 = ... - @ - - Then the following conditions must hold: - - 1. @v1@ and @v2@ must be distinct type variables. - 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. - --} - -{- $make - -There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type -or data family instance without having to make the type an instance of 'Bifunctor'. For -these cases, this module provides several functions (all prefixed with @make@-) that -splice the appropriate lambda expression into your source code. - -This is particularly useful for creating instances for sophisticated data types. For -example, 'deriveBifunctor' cannot infer the correct type context for -@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind -@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for -@HigherKinded@ without too much trouble using 'makeBimap': - -@ -{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} -import Data.Bifunctor -import Data.Bifunctor.TH - -newtype HigherKinded f a b c = HigherKinded (f a b c) - -instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where - bimap = $(makeBimap ''HigherKinded) -@ - --} - --- | Generates a 'Bifunctor' instance declaration for the given data type or data --- family instance. -deriveBifunctor :: Name -> Q [Dec] -deriveBifunctor = deriveBiClass Bifunctor - --- | Generates a lambda expression which behaves like 'bimap' (without requiring a --- 'Bifunctor' instance). -makeBimap :: Name -> Q Exp -makeBimap = makeBiFun Bimap - --- | Generates a 'Bifoldable' instance declaration for the given data type or data --- family instance. -deriveBifoldable :: Name -> Q [Dec] -deriveBifoldable = deriveBiClass Bifoldable - --- | Generates a lambda expression which behaves like 'bifold' (without requiring a --- 'Bifoldable' instance). -makeBifold :: Name -> Q Exp -makeBifold name = appsE [ makeBifoldMap name - , varE idValName - , varE idValName - ] - --- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a --- 'Bifoldable' instance). -makeBifoldMap :: Name -> Q Exp -makeBifoldMap = makeBiFun BifoldMap - --- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a --- 'Bifoldable' instance). -makeBifoldr :: Name -> Q Exp -makeBifoldr = makeBiFun Bifoldr - --- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a --- 'Bifoldable' instance). -makeBifoldl :: Name -> Q Exp -makeBifoldl name = do - f <- newName "f" - g <- newName "g" - z <- newName "z" - t <- newName "t" - lamE [varP f, varP g, varP z, varP t] $ - appsE [ varE appEndoValName - , appsE [ varE getDualValName - , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t] - ] - , varE z - ] - where - foldFun :: Name -> Q Exp - foldFun n = infixApp (conE dualDataName) - (varE composeValName) - (infixApp (conE endoDataName) - (varE composeValName) - (varE flipValName `appE` varE n) - ) - --- | Generates a 'Bitraversable' instance declaration for the given data type or data --- family instance. -deriveBitraversable :: Name -> Q [Dec] -deriveBitraversable = deriveBiClass Bitraversable - --- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a --- 'Bitraversable' instance). -makeBitraverse :: Name -> Q Exp -makeBitraverse = makeBiFun Bitraverse - --- | Generates a lambda expression which behaves like 'bisequenceA' (without requiring a --- 'Bitraversable' instance). -makeBisequenceA :: Name -> Q Exp -makeBisequenceA name = appsE [ makeBitraverse name - , varE idValName - , varE idValName - ] - --- | Generates a lambda expression which behaves like 'bimapM' (without requiring a --- 'Bitraversable' instance). -makeBimapM :: Name -> Q Exp -makeBimapM name = do - f <- newName "f" - g <- newName "g" - lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ - appsE [makeBitraverse name, wrapMonadExp f, wrapMonadExp g] - where - wrapMonadExp :: Name -> Q Exp - wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) - --- | Generates a lambda expression which behaves like 'bisequence' (without requiring a --- 'Bitraversable' instance). -makeBisequence :: Name -> Q Exp -makeBisequence name = appsE [ makeBimapM name - , varE idValName - , varE idValName - ] - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Derive a class instance declaration (depending on the BiClass argument's value). -deriveBiClass :: BiClass -> Name -> Q [Dec] -deriveBiClass biClass name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance biClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (biFunDecs biClass cons) - --- | Generates a declaration defining the primary function(s) corresponding to a --- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and --- bitraverse for Bitraversable). --- --- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436. -biFunDecs :: BiClass -> [Con] -> [Q Dec] -biFunDecs biClass cons = map makeFunD $ biClassToFuns biClass where - makeFunD :: BiFun -> Q Dec - makeFunD biFun = - funD (biFunName biFun) - [ clause [] - (normalB $ makeBiFunForCons biFun cons) - [] - ] - --- | Generates a lambda expression which behaves like the BiFun argument. -makeBiFun :: BiFun -> Name -> Q Exp -makeBiFun biFun name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance (biFunToClass biFun) name' ctxt tvbs mbTys - `seq` makeBiFunForCons biFun cons - --- | Generates a lambda expression for the given constructors. --- All constructors must be from the same type. -makeBiFunForCons :: BiFun -> [Con] -> Q Exp -makeBiFunForCons biFun cons = do - argNames <- mapM newName $ catMaybes [ Just "f" - , Just "g" - , guard (biFun == Bifoldr) >> Just "z" - , Just "value" - ] - let ([map1, map2], others) = splitAt 2 argNames - z = head others -- If we're deriving bifoldr, this will be well defined - -- and useful. Otherwise, it'll be ignored. - value = last others - lamE (map varP argNames) - . appsE - $ [ varE $ biFunConstName biFun - , if null cons - then appE (varE errorValName) - (stringE $ "Void " ++ nameBase (biFunName biFun)) - else caseE (varE value) - (map (makeBiFunForCon biFun z map1 map2) cons) - ] ++ map varE argNames - --- | Generates a lambda expression for a single constructor. -makeBiFunForCon :: BiFun -> Name -> Name -> Name -> Con -> Q Match -makeBiFunForCon biFun z map1 map2 con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys biFun conName map1 map2 - argNames <- newNameList "_arg" $ length ts - makeBiFunForArgs biFun z tvMap conName ts argNames - --- | Generates a lambda expression for a single constructor's arguments. -makeBiFunForArgs :: BiFun - -> Name - -> TyVarMap - -> Name - -> [Type] - -> [Name] - -> Q Match -makeBiFunForArgs biFun z tvMap conName tys args = - match (conP conName $ map varP args) - (normalB $ biFunCombine biFun conName z args mappedArgs) - [] - where - mappedArgs :: Q [Either Exp Exp] - mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args - --- | Generates a lambda expression for a single argument of a constructor. --- The returned value is 'Right' if its type mentions one of the last two type --- parameters. Otherwise, it is 'Left'. -makeBiFunForArg :: BiFun - -> TyVarMap - -> Name - -> Type - -> Name - -> Q (Either Exp Exp) -makeBiFunForArg biFun tvMap conName ty tyExpName = - makeBiFunForType biFun tvMap conName True ty `appEitherE` varE tyExpName - --- | Generates a lambda expression for a specific type. The returned value is --- 'Right' if its type mentions one of the last two type parameters. Otherwise, --- it is 'Left'. -makeBiFunForType :: BiFun - -> TyVarMap - -> Name - -> Bool - -> Type - -> Q (Either Exp Exp) -makeBiFunForType biFun tvMap conName covariant (VarT tyName) = - case Map.lookup tyName tvMap of - Just mapName -> fmap Right . varE $ - if covariant - then mapName - else contravarianceError conName - Nothing -> fmap Left $ biFunTriv biFun -makeBiFunForType biFun tvMap conName covariant (SigT ty _) = - makeBiFunForType biFun tvMap conName covariant ty -makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) = - makeBiFunForType biFun tvMap conName covariant ty -makeBiFunForType biFun tvMap conName covariant ty = - let tyCon :: Type - tyArgs :: [Type] - tyCon:tyArgs = unapplyTy ty - - numLastArgs :: Int - numLastArgs = min 2 $ length tyArgs - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - - mentionsTyArgs :: Bool - mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs - - makeBiFunTuple :: Type -> Name -> Q (Either Exp Exp) - makeBiFunTuple fieldTy fieldName = - makeBiFunForType biFun tvMap conName covariant fieldTy - `appEitherE` varE fieldName - - in case tyCon of - ArrowT - | not (allowFunTys (biFunToClass biFun)) -> noFunctionsError conName - | mentionsTyArgs, [argTy, resTy] <- tyArgs -> - do x <- newName "x" - b <- newName "b" - fmap Right . lamE [varP x, varP b] $ - covBiFun covariant resTy `appE` (varE x `appE` - (covBiFun (not covariant) argTy `appE` varE b)) - where - covBiFun :: Bool -> Type -> Q Exp - covBiFun cov = fmap fromEither . makeBiFunForType biFun tvMap conName cov - TupleT n - | n > 0 && mentionsTyArgs -> do - args <- mapM newName $ catMaybes [ Just "x" - , guard (biFun == Bifoldr) >> Just "z" - ] - xs <- newNameList "_tup" n - - let x = head args - z = last args - fmap Right $ lamE (map varP args) $ caseE (varE x) - [ match (tupP $ map varP xs) - (normalB $ biFunCombine biFun - (tupleDataName n) - z - xs - (zipWithM makeBiFunTuple tyArgs xs) - ) - [] - ] - _ -> do - itf <- isTyFamily tyCon - if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) - then outOfPlaceTyVarError conName - else if any (`mentionsName` tyVarNames) rhsArgs - then fmap Right . biFunApp biFun . appsE $ - ( varE (fromJust $ biFunArity biFun numLastArgs) - : map (fmap fromEither . makeBiFunForType biFun tvMap conName covariant) - rhsArgs - ) - else fmap Left $ biFunTriv biFun - -------------------------------------------------------------------------------- --- Template Haskell reifying and AST manipulation -------------------------------------------------------------------------------- - --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - con _ -> f name ctxt tvbs [con] Nothing - _ -> error $ ns ++ "Unsupported type: " ++ show dec -#if MIN_VERSION_template_haskell(2,7,0) -# if MIN_VERSION_template_haskell(2,11,0) - DataConI _ _ parentName -> do -# else - DataConI _ _ parentName _ -> do -# endif - parentInfo <- reify parentName - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> error $ ns ++ - "Could not find data or newtype instance constructor." - _ -> error $ ns ++ "Data constructor " ++ show name ++ - " is not from a data family instance constructor." -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI DataFamilyD{} _ -> -# else - FamilyI (FamilyD DataFam _ _ _) _ -> -# endif - error $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> error $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Bifunctor.TH.withType: " - --- | Deduces the instance context and head for an instance. -buildTypeInstance :: BiClass - -- ^ Bifunctor, Bifoldable, or Bitraversable - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type - -> Q (Cxt, Type) --- Plain data type/newtype case -buildTypeInstance biClass tyConName dataCxt tvbs Nothing = - let varTys :: [Type] - varTys = map tvbToType tvbs - in buildTypeInstanceFromTys biClass tyConName dataCxt varTys False --- Data family instance case --- --- The CPP is present to work around a couple of annoying old GHC bugs. --- See Note [Polykinded data families in Template Haskell] -buildTypeInstance biClass parentName dataCxt tvbs (Just instTysAndKinds) = do -#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) - let instTys :: [Type] - instTys = zipWith stealKindForType tvbs instTysAndKinds -#else - let kindVarNames :: [Name] - kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs - - numKindVars :: Int - numKindVars = length kindVarNames - - givenKinds, givenKinds' :: [Kind] - givenTys :: [Type] - (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds - givenKinds' = map sanitizeStars givenKinds - - -- A GHC 7.6-specific bug requires us to replace all occurrences of - -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. - -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. - sanitizeStars :: Kind -> Kind - sanitizeStars = go - where - go :: Kind -> Kind - go (AppT t1 t2) = AppT (go t1) (go t2) - go (SigT t k) = SigT (go t) (go k) - go (ConT n) | n == starKindName = StarT - go t = t - - -- If we run this code with GHC 7.8, we might have to generate extra type - -- variables to compensate for any type variables that Template Haskell - -- eta-reduced away. - -- See Note [Polykinded data families in Template Haskell] - xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) - - let xTys :: [Type] - xTys = map VarT xTypeNames - -- ^ Because these type variables were eta-reduced away, we can only - -- determine their kind by using stealKindForType. Therefore, we mark - -- them as VarT to ensure they will be given an explicit kind annotation - -- (and so the kind inference machinery has the right information). - - substNamesWithKinds :: [(Name, Kind)] -> Type -> Type - substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks - - -- The types from the data family instance might not have explicit kind - -- annotations, which the kind machinery needs to work correctly. To - -- compensate, we use stealKindForType to explicitly annotate any - -- types without kind annotations. - instTys :: [Type] - instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) - -- ^ Note that due to a GHC 7.8-specific bug - -- (see Note [Polykinded data families in Template Haskell]), - -- there may be more kind variable names than there are kinds - -- to substitute. But this is OK! If a kind is eta-reduced, it - -- means that is was not instantiated to something more specific, - -- so we need not substitute it. Using stealKindForType will - -- grab the correct kind. - $ zipWith stealKindForType tvbs (givenTys ++ xTys) -#endif - buildTypeInstanceFromTys biClass parentName dataCxt instTys True - --- For the given Types, generate an instance context and head. Coming up with --- the instance type isn't as simple as dropping the last types, as you need to --- be wary of kinds being instantiated with *. --- See Note [Type inference in derived instances] -buildTypeInstanceFromTys :: BiClass - -- ^ Bifunctor, Bifoldable, or Bitraversable - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [Type] - -- ^ The types to instantiate the instance with - -> Bool - -- ^ True if it's a data family, False otherwise - -> Q (Cxt, Type) -buildTypeInstanceFromTys biClass tyConName dataCxt varTysOrig isDataFamily = do - -- Make sure to expand through type/kind synonyms! Otherwise, the - -- eta-reduction check might get tripped up over type variables in a - -- synonym that are actually dropped. - -- (See GHC Trac #11416 for a scenario where this actually happened.) - varTysExp <- mapM expandSyn varTysOrig - - let remainingLength :: Int - remainingLength = length varTysOrig - 2 - - droppedTysExp :: [Type] - droppedTysExp = drop remainingLength varTysExp - - droppedStarKindStati :: [StarKindStatus] - droppedStarKindStati = map canRealizeKindStar droppedTysExp - - -- Check there are enough types to drop and that all of them are either of - -- kind * or kind k (for some kind variable k). If not, throw an error. - when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ - derivingKindError biClass tyConName - - let droppedKindVarNames :: [Name] - droppedKindVarNames = catKindVarNames droppedStarKindStati - - -- Substitute kind * for any dropped kind variables - varTysExpSubst :: [Type] - varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp - - remainingTysExpSubst, droppedTysExpSubst :: [Type] - (remainingTysExpSubst, droppedTysExpSubst) = - splitAt remainingLength varTysExpSubst - - -- All of the type variables mentioned in the dropped types - -- (post-synonym expansion) - droppedTyVarNames :: [Name] - droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst - - -- If any of the dropped types were polykinded, ensure that they are of kind * - -- after substituting * for the dropped kind variables. If not, throw an error. - unless (all hasKindStar droppedTysExpSubst) $ - derivingKindError biClass tyConName - - let preds :: [Maybe Pred] - kvNames :: [[Name]] - kvNames' :: [Name] - -- Derive instance constraints (and any kind variables which are specialized - -- to * in those constraints) - (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst - kvNames' = concat kvNames - - -- Substitute the kind variables specialized in the constraints with * - remainingTysExpSubst' :: [Type] - remainingTysExpSubst' = - map (substNamesWithKindStar kvNames') remainingTysExpSubst - - -- We now substitute all of the specialized-to-* kind variable names with - -- *, but in the original types, not the synonym-expanded types. The reason - -- we do this is a superficial one: we want the derived instance to resemble - -- the datatype written in source code as closely as possible. For example, - -- for the following data family instance: - -- - -- data family Fam a - -- newtype instance Fam String = Fam String - -- - -- We'd want to generate the instance: - -- - -- instance C (Fam String) - -- - -- Not: - -- - -- instance C (Fam [Char]) - remainingTysOrigSubst :: [Type] - remainingTysOrigSubst = - map (substNamesWithKindStar (union droppedKindVarNames kvNames')) - $ take remainingLength varTysOrig - - remainingTysOrigSubst' :: [Type] - -- See Note [Kind signatures in derived instances] for an explanation - -- of the isDataFamily check. - remainingTysOrigSubst' = - if isDataFamily - then remainingTysOrigSubst - else map unSigT remainingTysOrigSubst - - instanceCxt :: Cxt - instanceCxt = catMaybes preds - - instanceType :: Type - instanceType = AppT (ConT $ biClassName biClass) - $ applyTyCon tyConName remainingTysOrigSubst' - - -- If the datatype context mentions any of the dropped type variables, - -- we can't derive an instance, so throw an error. - when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ - datatypeContextError tyConName instanceType - -- Also ensure the dropped types can be safely eta-reduced. Otherwise, - -- throw an error. - unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ - etaReductionError instanceType - return (instanceCxt, instanceType) - --- | Attempt to derive a constraint on a Type. If successful, return --- Just the constraint and any kind variable names constrained to *. --- Otherwise, return Nothing and the empty list. --- --- See Note [Type inference in derived instances] for the heuristics used to --- come up with constraints. -deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name]) -deriveConstraint biClass t - | not (isTyVar t) = (Nothing, []) - | otherwise = case hasKindVarChain 1 t of - Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns) - _ -> case hasKindVarChain 2 t of - Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns) - _ -> (Nothing, []) - where - tName :: Name - tName = varTToName t - -{- -Note [Polykinded data families in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In order to come up with the correct instance context and head for an instance, e.g., - - instance C a => C (Data a) where ... - -We need to know the exact types and kinds used to instantiate the instance. For -plain old datatypes, this is simple: every type must be a type variable, and -Template Haskell reliably tells us the type variables and their kinds. - -Doing the same for data families proves to be much harder for three reasons: - -1. On any version of Template Haskell, it may not tell you what an instantiated - type's kind is. For instance, in the following data family instance: - - data family Fam (f :: * -> *) (a :: *) - data instance Fam f a - - Then if we use TH's reify function, it would tell us the TyVarBndrs of the - data family declaration are: - - [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] - - and the instantiated types of the data family instance are: - - [VarT f1,VarT a1] - - We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we - have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the - kind is in case an instantiated type isn't a SigT, so we use the stealKindForType - function to ensure all of the instantiated types are SigTs before passing them - to buildTypeInstanceFromTys. -2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of - the specified kinds of a data family instance efore any of the instantiated - types. Fortunately, this is easy to deal with: you simply count the number of - distinct kind variables in the data family declaration, take that many elements - from the front of the Types list of the data family instance, substitute the - kind variables with their respective instantiated kinds (which you took earlier), - and proceed as normal. -3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template - Haskell might not even list all of the Types of a data family instance, since - they are eta-reduced away! And yes, kinds can be eta-reduced too. - - The simplest workaround is to count how many instantiated types are missing from - the list and generate extra type variables to use in their place. Luckily, we - needn't worry much if its kind was eta-reduced away, since using stealKindForType - will get it back. - -Note [Kind signatures in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is possible to put explicit kind signatures into the derived instances, e.g., - - instance C a => C (Data (f :: * -> *)) where ... - -But it is preferable to avoid this if possible. If we come up with an incorrect -kind signature (which is entirely possible, since our type inferencer is pretty -unsophisticated - see Note [Type inference in derived instances]), then GHC will -flat-out reject the instance, which is quite unfortunate. - -Plain old datatypes have the advantage that you can avoid using any kind signatures -at all in their instances. This is because a datatype declaration uses all type -variables, so the types that we use in a derived instance uniquely determine their -kinds. As long as we plug in the right types, the kind inferencer can do the rest -of the work. For this reason, we use unSigT to remove all kind signatures before -splicing in the instance context and head. - -Data family instances are trickier, since a data family can have two instances that -are distinguished by kind alone, e.g., - - data family Fam (a :: k) - data instance Fam (a :: * -> *) - data instance Fam (a :: *) - -If we dropped the kind signatures for C (Fam a), then GHC will have no way of -knowing which instance we are talking about. To avoid this scenario, we always -include explicit kind signatures in data family instances. There is a chance that -the inferred kind signatures will be incorrect, but if so, we can always fall back -on the make- functions. - -Note [Type inference in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Type inference is can be tricky to get right, and we want to avoid recreating the -entirety of GHC's type inferencer in Template Haskell. For this reason, we will -probably never come up with derived instance contexts that are as accurate as -GHC's. But that doesn't mean we can't do anything! There are a couple of simple -things we can do to make instance contexts that work for 80% of use cases: - -1. If one of the last type parameters is polykinded, then its kind will be - specialized to * in the derived instance. We note what kind variable the type - parameter had and substitute it with * in the other types as well. For example, - imagine you had - - data Data (a :: k) (b :: k) (c :: k) - - Then you'd want to derived instance to be: - - instance C (Data (a :: *)) - - Not: - - instance C (Data (a :: k)) - -2. We naïvely come up with instance constraints using the following criteria: - - (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind - variables), then generate a Functor n constraint, and if k1/k2 are kind - variables, then substitute k1/k2 with * elsewhere in the types. We must - consider the case where they are kind variables because you might have a - scenario like this: - - newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) - = Compose (f (g a b)) - - Which would have a derived Bifunctor instance of: - - instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... - (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are - * or kind variables), then generate a Bifunctor n constraint and perform - kind substitution as in the other case. --} - --- Determines the types of a constructor's arguments as well as the last type --- parameters (along with their map functions), expanding through any type synonyms. --- The type parameters are determined on a constructor-by-constructor basis since --- they may be refined to be particular types in a GADT. -reifyConTys :: BiFun - -> Name - -> Name - -> Name - -> Q ([Type], TyVarMap) -reifyConTys biFun conName map1 map2 = do - info <- reify conName - (ctxt, uncTy) <- case info of - DataConI _ ty _ -#if !(MIN_VERSION_template_haskell(2,11,0)) - _ -#endif - -> fmap uncurryTy (expandSyn ty) - _ -> error "Must be a data constructor" - let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy - unapResTy = unapplyTy resTy - -- If one of the last type variables is refined to a particular type - -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply map functions to arguments of - -- a type that it (1) one of the last type variables, and (2) - -- of a truly polymorphic type. - mbTvNames = map varTToName_maybe $ - drop (length unapResTy - 2) unapResTy - -- We use Map.fromList to ensure that if there are any duplicate type - -- variables (as can happen in a GADT), the rightmost type variable gets - -- associated with the map function. - -- - -- See Note [Matching functions with GADT type variables] - tvMap = Map.fromList - . catMaybes -- Drop refined types - $ zipWith (\mbTvName sp -> - fmap (\tvName -> (tvName, sp)) mbTvName) - mbTvNames [map1, map2] - if (any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < 2) - && not (allowExQuant (biFunToClass biFun)) - then existentialContextError conName - else return (argTys, tvMap) - -{- -Note [Matching functions with GADT type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When deriving Bifoldable, there is a tricky corner case to consider: - - data Both a b where - BothCon :: x -> x -> Both x x - -Which fold functions should be applied to which arguments of BothCon? We have a -choice, since both the function of type (a -> m) and of type (b -> m) can be -applied to either argument. In such a scenario, the second fold function takes -precedence over the first fold function, so the derived Bifoldable instance would be: - - instance Bifoldable Both where - bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2 - -This is not an arbitrary choice, as this definition ensures that -bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both. --} - -------------------------------------------------------------------------------- --- Error messages -------------------------------------------------------------------------------- - --- | Either the given data type doesn't have enough type variables, or one of --- the type variables to be eta-reduced cannot realize kind *. -derivingKindError :: BiClass -> Name -> a -derivingKindError biClass tyConName = error - . showString "Cannot derive well-kinded instance of form ‘" - . showString className - . showChar ' ' - . showParen True - ( showString (nameBase tyConName) - . showString " ..." - ) - . showString "‘\n\tClass " - . showString className - . showString " expects an argument of kind * -> * -> *" - $ "" - where - className :: String - className = nameBase $ biClassName biClass - --- | One of the last two type variables appeard in a contravariant position --- when deriving Bifoldable or Bitraversable. -contravarianceError :: Name -> a -contravarianceError conName = error - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must not use the last type variable(s) in a function argument" - $ "" - --- | A constructor has a function argument in a derived Bifoldable or Bitraversable --- instance. -noFunctionsError :: Name -> a -noFunctionsError conName = error - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must not contain function types" - $ "" - --- | The data type has a DatatypeContext which mentions one of the eta-reduced --- type variables. -datatypeContextError :: Name -> Type -> a -datatypeContextError dataName instanceType = error - . showString "Can't make a derived instance of ‘" - . showString (pprint instanceType) - . showString "‘:\n\tData type ‘" - . showString (nameBase dataName) - . showString "‘ must not have a class context involving the last type argument(s)" - $ "" - --- | The data type has an existential constraint which mentions one of the --- eta-reduced type variables. -existentialContextError :: Name -> a -existentialContextError conName = error - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must be truly polymorphic in the last argument(s) of the data type" - $ "" - --- | The data type mentions one of the n eta-reduced type variables in a place other --- than the last nth positions of a data type in a constructor's field. -outOfPlaceTyVarError :: Name -> a -outOfPlaceTyVarError conName = error - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must only use its last two type variable(s) within" - . showString " the last two argument(s) of a data type" - $ "" - --- | One of the last type variables cannot be eta-reduced (see the canEtaReduce --- function for the criteria it would have to meet). -etaReductionError :: Type -> a -etaReductionError instanceType = error $ - "Cannot eta-reduce to an instance of form \n\tinstance (...) => " - ++ pprint instanceType - -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. -dataConIError :: a -dataConIError = error - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive for a data family instance," - . showString "\n\tuse GHC >= 7.4 instead.)" - $ "" -#endif - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which class is being derived. -data BiClass = Bifunctor | Bifoldable | Bitraversable - --- | A representation of which function is being generated. -data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse - deriving Eq - -biFunConstName :: BiFun -> Name -biFunConstName Bimap = bimapConstValName -biFunConstName Bifoldr = bifoldrConstValName -biFunConstName BifoldMap = bifoldMapConstValName -biFunConstName Bitraverse = bitraverseConstValName - -biClassName :: BiClass -> Name -biClassName Bifunctor = bifunctorTypeName -biClassName Bifoldable = bifoldableTypeName -biClassName Bitraversable = bitraversableTypeName - -biFunName :: BiFun -> Name -biFunName Bimap = bimapValName -biFunName Bifoldr = bifoldrValName -biFunName BifoldMap = bifoldMapValName -biFunName Bitraverse = bitraverseValName - -biClassToFuns :: BiClass -> [BiFun] -biClassToFuns Bifunctor = [Bimap] -biClassToFuns Bifoldable = [Bifoldr, BifoldMap] -biClassToFuns Bitraversable = [Bitraverse] - -biFunToClass :: BiFun -> BiClass -biFunToClass Bimap = Bifunctor -biFunToClass Bifoldr = Bifoldable -biFunToClass BifoldMap = Bifoldable -biFunToClass Bitraverse = Bitraversable - -biClassConstraint :: BiClass -> Int -> Maybe Name -biClassConstraint Bifunctor 1 = Just functorTypeName -biClassConstraint Bifoldable 1 = Just foldableTypeName -biClassConstraint Bitraversable 1 = Just traversableTypeName -biClassConstraint biClass 2 = Just $ biClassName biClass -biClassConstraint _ _ = Nothing - -biFunArity :: BiFun -> Int -> Maybe Name -biFunArity Bimap 1 = Just fmapValName -biFunArity Bifoldr 1 = Just foldrValName -biFunArity BifoldMap 1 = Just foldMapValName -biFunArity Bitraverse 1 = Just traverseValName -biFunArity biFun 2 = Just $ biFunName biFun -biFunArity _ _ = Nothing - -allowFunTys :: BiClass -> Bool -allowFunTys Bifunctor = True -allowFunTys _ = False - -allowExQuant :: BiClass -> Bool -allowExQuant Bifoldable = True -allowExQuant _ = False - --- See Trac #7436 for why explicit lambdas are used -biFunTriv :: BiFun -> Q Exp -biFunTriv Bimap = do - x <- newName "x" - lamE [varP x] $ varE x --- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem --- useless, but they do serve a purpose. --- See Note [biFunTriv for Bifoldable and Bitraversable] -biFunTriv Bifoldr = do - z <- newName "z" - lamE [wildP, varP z] $ varE z -biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName -biFunTriv Bitraverse = varE pureValName - -biFunApp :: BiFun -> Q Exp -> Q Exp -biFunApp Bifoldr e = do - x <- newName "x" - z <- newName "z" - lamE [varP x, varP z] $ appsE [e, varE z, varE x] -biFunApp _ e = e - -biFunCombine :: BiFun - -> Name - -> Name - -> [Name] - -> Q [Either Exp Exp] - -> Q Exp -biFunCombine Bimap = bimapCombine -biFunCombine Bifoldr = bifoldrCombine -biFunCombine BifoldMap = bifoldMapCombine -biFunCombine Bitraverse = bitraverseCombine - -bimapCombine :: Name - -> Name - -> [Name] - -> Q [Either Exp Exp] - -> Q Exp -bimapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither) - --- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since --- they filter out subexpressions whose types do not mention one of the last two --- type parameters. See --- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable --- for further discussion. - -bifoldrCombine :: Name - -> Name - -> [Name] - -> Q [Either Exp Exp] - -> Q Exp -bifoldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights) - -bifoldMapCombine :: Name - -> Name - -> [Name] - -> Q [Either Exp Exp] - -> Q Exp -bifoldMapCombine _ _ _ = fmap (go . rights) - where - go :: [Exp] -> Exp - go [] = VarE memptyValName - go es = foldr1 (AppE . AppE (VarE mappendValName)) es - -bitraverseCombine :: Name - -> Name - -> [Name] - -> Q [Either Exp Exp] - -> Q Exp -bitraverseCombine conName _ args essQ = do - ess <- essQ - - let argTysTyVarInfo :: [Bool] - argTysTyVarInfo = map isRight ess - - argsWithTyVar, argsWithoutTyVar :: [Name] - (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args - - conExpQ :: Q Exp - conExpQ - | null argsWithTyVar - = appsE (conE conName:map varE argsWithoutTyVar) - | otherwise = do - bs <- newNameList "b" $ length args - let bs' = filterByList argTysTyVarInfo bs - vars = filterByLists argTysTyVarInfo - (map varE bs) (map varE args) - lamE (map varP bs') (appsE (conE conName:vars)) - - conExp <- conExpQ - - let go :: [Exp] -> Exp - go [] = VarE pureValName `AppE` conExp - go (e:es) = foldl' (\e1 e2 -> InfixE (Just e1) (VarE apValName) (Just e2)) - (VarE fmapValName `AppE` conExp `AppE` e) es - - return . go . rights $ ess - -{- -Note [biFunTriv for Bifoldable and Bitraversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose -type does not mention one of the last two type parameters. From this, you might -think that we don't need to implement biFunTriv for bifoldr, bifoldMap, or -bitraverse at all, but in fact we do need to. Imagine the following data type: - - data T a b = MkT a (T Int b) - -In a derived Bifoldable T instance, you would generate the following bifoldMap -definition: - - bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 - -You need to fill in biFunTriv (\_ -> mempty) as the first argument to the recursive -call to bifoldMap, since that is how the algorithm handles polymorphic recursion. --} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Unsafe #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- Functions to mechanically derive 'Bifunctor', 'Bifoldable', +-- or 'Bitraversable' instances, or to splice their functions directly into +-- source code. You need to enable the @TemplateHaskell@ language extension +-- in order to use this module. +---------------------------------------------------------------------------- + +module Data.Bifunctor.TH ( + -- * @derive@- functions + -- $derive + -- * @make@- functions + -- $make + -- * 'Bifunctor' + deriveBifunctor + , deriveBifunctorOptions + , makeBimap + , makeBimapOptions + -- * 'Bifoldable' + , deriveBifoldable + , deriveBifoldableOptions + , makeBifold + , makeBifoldOptions + , makeBifoldMap + , makeBifoldMapOptions + , makeBifoldr + , makeBifoldrOptions + , makeBifoldl + , makeBifoldlOptions + -- * 'Bitraversable' + , deriveBitraversable + , deriveBitraversableOptions + , makeBitraverse + , makeBitraverseOptions + , makeBisequenceA + , makeBisequenceAOptions + , makeBimapM + , makeBimapMOptions + , makeBisequence + , makeBisequenceOptions + -- * 'Options' + , Options(..) + , defaultOptions + ) where + +import Control.Monad (guard, unless, when) + +import Data.Bifunctor.TH.Internal +import qualified Data.List as List +import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size) +import Data.Maybe + +import Language.Haskell.TH.Datatype as Datatype +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Syntax + +------------------------------------------------------------------------------- +-- User-facing API +------------------------------------------------------------------------------- + +-- | Options that further configure how the functions in "Data.Bifunctor.TH" +-- should behave. +newtype Options = Options + { emptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + } deriving (Eq, Ord, Read, Show) + +-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to +-- prevent users from having to enable that extension at use sites.) +defaultOptions :: Options +defaultOptions = Options { emptyCaseBehavior = False } + +{- $derive + +'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically +generate their respective class instances for a given data type, newtype, or data +family instance that has at least two type variable. Examples: + +@ +{-# LANGUAGE TemplateHaskell #-} +import Data.Bifunctor.TH + +data Pair a b = Pair a b +$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ... + +data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b) +$('deriveBifoldable' ''WrapLeftPair) +-- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ... +@ + +If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), +the @derive@ functions can be used data family instances (which requires the +@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance +constructor (NOT a data family name!) to a @derive@ function. Note that the +generated code may require the @-XFlexibleInstances@ extension. Example: + +@ +{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} +import Data.Bifunctor.TH + +class AssocClass a b c where + data AssocData a b c +instance AssocClass Int b c where + data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c +$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ... +-- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2) +@ + +Note that there are some limitations: + +* The 'Name' argument to a @derive@ function must not be a type synonym. + +* With a @derive@ function, the last two type variables must both be of kind @*@. + Other type variables of kind @* -> *@ are assumed to require a 'Functor', + 'Foldable', or 'Traversable' constraint (depending on which @derive@ function is + used), and other type variables of kind @* -> * -> *@ are assumed to require an + 'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type + doesn't meet these assumptions, use a @make@ function. + +* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@ + extensions, a constraint cannot mention either of the last two type variables. For + example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot + have a derived 'Bifunctor' instance. + +* If either of the last two type variables is used within a constructor argument's + type, it must only be used in the last two type arguments. For example, + @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance, + but @data Illegal a b = Illegal (a, b, a, b)@ cannot. + +* Data family instances must be able to eta-reduce the last two type variables. In other + words, if you have a instance of the form: + + @ + data family Family a1 ... an t1 t2 + data instance Family e1 ... e2 v1 v2 = ... + @ + + Then the following conditions must hold: + + 1. @v1@ and @v2@ must be distinct type variables. + 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. + +-} + +{- $make + +There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type +or data family instance without having to make the type an instance of 'Bifunctor'. For +these cases, this module provides several functions (all prefixed with @make@-) that +splice the appropriate lambda expression into your source code. + +This is particularly useful for creating instances for sophisticated data types. For +example, 'deriveBifunctor' cannot infer the correct type context for +@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind +@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for +@HigherKinded@ without too much trouble using 'makeBimap': + +@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +import Data.Bifunctor +import Data.Bifunctor.TH + +newtype HigherKinded f a b c = HigherKinded (f a b c) + +instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where + bimap = $(makeBimap ''HigherKinded) +@ + +-} + +-- | Generates a 'Bifunctor' instance declaration for the given data type or data +-- family instance. +deriveBifunctor :: Name -> Q [Dec] +deriveBifunctor = deriveBifunctorOptions defaultOptions + +-- | Like 'deriveBifunctor', but takes an 'Options' argument. +deriveBifunctorOptions :: Options -> Name -> Q [Dec] +deriveBifunctorOptions = deriveBiClass Bifunctor + +-- | Generates a lambda expression which behaves like 'bimap' (without requiring a +-- 'Bifunctor' instance). +makeBimap :: Name -> Q Exp +makeBimap = makeBimapOptions defaultOptions + +-- | Like 'makeBimap', but takes an 'Options' argument. +makeBimapOptions :: Options -> Name -> Q Exp +makeBimapOptions = makeBiFun Bimap + +-- | Generates a 'Bifoldable' instance declaration for the given data type or data +-- family instance. +deriveBifoldable :: Name -> Q [Dec] +deriveBifoldable = deriveBifoldableOptions defaultOptions + +-- | Like 'deriveBifoldable', but takes an 'Options' argument. +deriveBifoldableOptions :: Options -> Name -> Q [Dec] +deriveBifoldableOptions = deriveBiClass Bifoldable + +--- | Generates a lambda expression which behaves like 'bifold' (without requiring a +-- 'Bifoldable' instance). +makeBifold :: Name -> Q Exp +makeBifold = makeBifoldOptions defaultOptions + +-- | Like 'makeBifold', but takes an 'Options' argument. +makeBifoldOptions :: Options -> Name -> Q Exp +makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name + , varE idValName + , varE idValName + ] + +-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring +-- a 'Bifoldable' instance). +makeBifoldMap :: Name -> Q Exp +makeBifoldMap = makeBifoldMapOptions defaultOptions + +-- | Like 'makeBifoldMap', but takes an 'Options' argument. +makeBifoldMapOptions :: Options -> Name -> Q Exp +makeBifoldMapOptions = makeBiFun BifoldMap + +-- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a +-- 'Bifoldable' instance). +makeBifoldr :: Name -> Q Exp +makeBifoldr = makeBifoldrOptions defaultOptions + +-- | Like 'makeBifoldr', but takes an 'Options' argument. +makeBifoldrOptions :: Options -> Name -> Q Exp +makeBifoldrOptions = makeBiFun Bifoldr + +-- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a +-- 'Bifoldable' instance). +makeBifoldl :: Name -> Q Exp +makeBifoldl = makeBifoldlOptions defaultOptions + +-- | Like 'makeBifoldl', but takes an 'Options' argument. +makeBifoldlOptions :: Options -> Name -> Q Exp +makeBifoldlOptions opts name = do + f <- newName "f" + g <- newName "g" + z <- newName "z" + t <- newName "t" + lamE [varP f, varP g, varP z, varP t] $ + appsE [ varE appEndoValName + , appsE [ varE getDualValName + , appsE [ makeBifoldMapOptions opts name + , foldFun f + , foldFun g + , varE t] + ] + , varE z + ] + where + foldFun :: Name -> Q Exp + foldFun n = infixApp (conE dualDataName) + (varE composeValName) + (infixApp (conE endoDataName) + (varE composeValName) + (varE flipValName `appE` varE n) + ) + +-- | Generates a 'Bitraversable' instance declaration for the given data type or data +-- family instance. +deriveBitraversable :: Name -> Q [Dec] +deriveBitraversable = deriveBitraversableOptions defaultOptions + +-- | Like 'deriveBitraversable', but takes an 'Options' argument. +deriveBitraversableOptions :: Options -> Name -> Q [Dec] +deriveBitraversableOptions = deriveBiClass Bitraversable + +-- | Generates a lambda expression which behaves like 'bitraverse' (without +-- requiring a 'Bitraversable' instance). +makeBitraverse :: Name -> Q Exp +makeBitraverse = makeBitraverseOptions defaultOptions + +-- | Like 'makeBitraverse', but takes an 'Options' argument. +makeBitraverseOptions :: Options -> Name -> Q Exp +makeBitraverseOptions = makeBiFun Bitraverse + +-- | Generates a lambda expression which behaves like 'bisequenceA' (without +-- requiring a 'Bitraversable' instance). +makeBisequenceA :: Name -> Q Exp +makeBisequenceA = makeBisequenceAOptions defaultOptions + +-- | Like 'makeBitraverseA', but takes an 'Options' argument. +makeBisequenceAOptions :: Options -> Name -> Q Exp +makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name + , varE idValName + , varE idValName + ] + +-- | Generates a lambda expression which behaves like 'bimapM' (without +-- requiring a 'Bitraversable' instance). +makeBimapM :: Name -> Q Exp +makeBimapM = makeBimapMOptions defaultOptions + +-- | Like 'makeBimapM', but takes an 'Options' argument. +makeBimapMOptions :: Options -> Name -> Q Exp +makeBimapMOptions opts name = do + f <- newName "f" + g <- newName "g" + lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ + appsE [ makeBitraverseOptions opts name + , wrapMonadExp f + , wrapMonadExp g + ] + where + wrapMonadExp :: Name -> Q Exp + wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) + +-- | Generates a lambda expression which behaves like 'bisequence' (without +-- requiring a 'Bitraversable' instance). +makeBisequence :: Name -> Q Exp +makeBisequence = makeBisequenceOptions defaultOptions + +-- | Like 'makeBisequence', but takes an 'Options' argument. +makeBisequenceOptions :: Options -> Name -> Q Exp +makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name + , varE idValName + , varE idValName + ] + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive a class instance declaration (depending on the BiClass argument's value). +deriveBiClass :: BiClass -> Options -> Name -> Q [Dec] +deriveBiClass biClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTys + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance biClass parentName ctxt instTys variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (biFunDecs biClass opts parentName instTys cons) + +-- | Generates a declaration defining the primary function(s) corresponding to a +-- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and +-- bitraverse for Bitraversable). +-- +-- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436. +biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] +biFunDecs biClass opts parentName instTys cons = + map makeFunD $ biClassToFuns biClass + where + makeFunD :: BiFun -> Q Dec + makeFunD biFun = + funD (biFunName biFun) + [ clause [] + (normalB $ makeBiFunForCons biFun opts parentName instTys cons) + [] + ] + +-- | Generates a lambda expression which behaves like the BiFun argument. +makeBiFun :: BiFun -> Options -> Name -> Q Exp +makeBiFun biFun opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTys + , datatypeVariant = variant + , datatypeCons = cons + } -> + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance (biFunToClass biFun) parentName ctxt instTys variant + >> makeBiFunForCons biFun opts parentName instTys cons + +-- | Generates a lambda expression for the given constructors. +-- All constructors must be from the same type. +makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp +makeBiFunForCons biFun opts _parentName instTys cons = do + map1 <- newName "f" + map2 <- newName "g" + z <- newName "z" -- Only used for deriving bifoldr + value <- newName "value" + let argNames = catMaybes [ Just map1 + , Just map2 + , guard (biFun == Bifoldr) >> Just z + , Just value + ] + lastTyVars = map varTToName $ drop (length instTys - 2) instTys + tvMap = Map.fromList $ zip lastTyVars [map1, map2] + lamE (map varP argNames) + . appsE + $ [ varE $ biFunConstName biFun + , makeFun z value tvMap + ] ++ map varE argNames + where + makeFun :: Name -> Name -> TyVarMap -> Q Exp + makeFun z value tvMap = do + roles <- reifyRoles _parentName + case () of + _ | Just (rs, PhantomR) <- unsnoc roles + , Just (_, PhantomR) <- unsnoc rs + -> biFunPhantom z value + + | null cons && emptyCaseBehavior opts + -> biFunEmptyCase biFun z value + + | null cons + -> biFunNoCons biFun z value + + | otherwise + -> caseE (varE value) + (map (makeBiFunForCon biFun z tvMap) cons) + + biFunPhantom :: Name -> Name -> Q Exp + biFunPhantom z value = + biFunTrivial coerce + (varE pureValName `appE` coerce) + biFun z + where + coerce :: Q Exp + coerce = varE coerceValName `appE` varE value + +-- | Generates a match for a single constructor. +makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match +makeBiFunForCon biFun z tvMap + con@(ConstructorInfo { constructorName = conName + , constructorContext = ctxt }) = do + when ((any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < 2) + && not (allowExQuant (biFunToClass biFun))) $ + existentialContextError conName + case biFun of + Bimap -> makeBimapMatch tvMap con + Bifoldr -> makeBifoldrMatch z tvMap con + BifoldMap -> makeBifoldMapMatch tvMap con + Bitraverse -> makeBitraverseMatch tvMap con + +-- | Generates a match whose right-hand side implements @bimap@. +makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match +makeBimapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_bimap con + match_for_con conName parts + where + ft_bimap :: FFoldType (Exp -> Q Exp) + ft_bimap = FT { ft_triv = return + , ft_var = \v x -> return $ VarE (tvMap Map.! v) `AppE` x + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ x `AppE` gg + , ft_tup = mkSimpleTupleCase match_for_con + , ft_ty_app = \argGs x -> do + let inspect :: (Type, Exp -> Q Exp) -> Q Exp + inspect (argTy, g) + -- If the argument type is a bare occurrence of one + -- of the data type's last type variables, then we + -- can generate more efficient code. + -- This was inspired by GHC#17880. + | Just argVar <- varTToName_maybe argTy + , Just f <- Map.lookup argVar tvMap + = return $ VarE f + | otherwise + = mkSimpleLam g + appsE $ varE (fmapArity (length argGs)) + : map inspect argGs + ++ [return x] + , ft_forall = \_ g x -> g x + , ft_bad_app = \_ -> outOfPlaceTyVarError conName + , ft_co_var = \_ _ -> contravarianceError conName + } + + -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... + match_for_con :: Name -> [Exp -> Q Exp] -> Q Match + match_for_con = mkSimpleConMatch $ \conName' xs -> + appsE (conE conName':xs) -- Con x1 x2 .. + +-- | Generates a match whose right-hand side implements @bifoldr@. +makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match +makeBifoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_bifoldr con + parts' <- sequence parts + match_for_con (VarE z) conName parts' + where + -- The Bool is True if the type mentions of the last two type parameters, + -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter + -- out expressions that do not mention the last parameters by checking for + -- False. + ft_bifoldr :: FFoldType (Q (Bool, Exp)) + ft_bifoldr = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] + ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z' + return (False, lam) + , ft_var = \v -> return (True, VarE $ tvMap Map.! v) + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam2 $ \x z' -> + mkSimpleTupleCase (match_for_con z') t gg x + return (True, lam) + , ft_ty_app = \gs -> do + lam <- mkSimpleLam2 $ \x z' -> + appsE $ varE (foldrArity (length gs)) + : map (\(_, hs) -> fmap snd hs) gs + ++ map return [z', x] + return (True, lam) + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError conName + } + + match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match + match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldr xs + where + -- g1 v1 (g2 v2 (.. z)) + mkBifoldr :: [Exp] -> Exp + mkBifoldr = foldr AppE zExp + +-- | Generates a match whose right-hand side implements @bifoldMap@. +makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match +makeBifoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_bifoldMap con + parts' <- sequence parts + match_for_con conName parts' + where + -- The Bool is True if the type mentions of the last two type parameters, + -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter + -- out expressions that do not mention the last parameters by checking for + -- False. + ft_bifoldMap :: FFoldType (Q (Bool, Exp)) + ft_bifoldMap = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] + ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName + return (False, lam) + , ft_var = \v -> return (True, VarE $ tvMap Map.! v) + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (True, lam) + , ft_ty_app = \gs -> do + e <- appsE $ varE (foldMapArity (length gs)) + : map (\(_, hs) -> fmap snd hs) gs + return (True, e) + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError conName + } + + match_for_con :: Name -> [(Bool, Exp)] -> Q Match + match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldMap xs + where + -- mappend v1 (mappend v2 ..) + mkBifoldMap :: [Exp] -> Exp + mkBifoldMap [] = VarE memptyValName + mkBifoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es + +-- | Generates a match whose right-hand side implements @bitraverse@. +makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match +makeBitraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_bitrav con + parts' <- sequence parts + match_for_con conName parts' + where + -- The Bool is True if the type mentions of the last two type parameters, + -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter + -- out expressions that do not mention the last parameters by checking for + -- False. + ft_bitrav :: FFoldType (Q (Bool, Exp)) + ft_bitrav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] + ft_triv = return (False, VarE pureValName) + , ft_var = \v -> return (True, VarE $ tvMap Map.! v) + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (True, lam) + , ft_ty_app = \gs -> do + e <- appsE $ varE (traverseArity (length gs)) + : map (\(_, hs) -> fmap snd hs) gs + return (True, e) + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError conName + } + + -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) + -- (g2 a2) <*> ... + match_for_con :: Name -> [(Bool, Exp)] -> Q Match + match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs + where + -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. + mkApCon :: Exp -> [Exp] -> Exp + mkApCon conExp [] = VarE pureValName `AppE` conExp + mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e + mkApCon conExp (e1:e2:es) = List.foldl' appAp + (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es + where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) + +------------------------------------------------------------------------------- +-- Template Haskell reifying and AST manipulation +------------------------------------------------------------------------------- + +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] +buildTypeInstance :: BiClass + -- ^ Bifunctor, Bifoldable, or Bitraversable + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not + -> Q (Cxt, Type) +buildTypeInstance biClass tyConName dataCxt instTysOrig variant = do + -- Make sure to expand through type/kind synonyms! Otherwise, the + -- eta-reduction check might get tripped up over type variables in a + -- synonym that are actually dropped. + -- (See GHC Trac #11416 for a scenario where this actually happened.) + varTysExp <- mapM resolveTypeSynonyms instTysOrig + + let remainingLength :: Int + remainingLength = length instTysOrig - 2 + + droppedTysExp :: [Type] + droppedTysExp = drop remainingLength varTysExp + + droppedStarKindStati :: [StarKindStatus] + droppedStarKindStati = map canRealizeKindStar droppedTysExp + + -- Check there are enough types to drop and that all of them are either of + -- kind * or kind k (for some kind variable k). If not, throw an error. + when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ + derivingKindError biClass tyConName + + let droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati + + -- Substitute kind * for any dropped kind variables + varTysExpSubst :: [Type] + varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp + + remainingTysExpSubst, droppedTysExpSubst :: [Type] + (remainingTysExpSubst, droppedTysExpSubst) = + splitAt remainingLength varTysExpSubst + + -- All of the type variables mentioned in the dropped types + -- (post-synonym expansion) + droppedTyVarNames :: [Name] + droppedTyVarNames = freeVariables droppedTysExpSubst + + -- If any of the dropped types were polykinded, ensure that they are of kind * + -- after substituting * for the dropped kind variables. If not, throw an error. + unless (all hasKindStar droppedTysExpSubst) $ + derivingKindError biClass tyConName + + let preds :: [Maybe Pred] + kvNames :: [[Name]] + kvNames' :: [Name] + -- Derive instance constraints (and any kind variables which are specialized + -- to * in those constraints) + (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst + kvNames' = concat kvNames + + -- Substitute the kind variables specialized in the constraints with * + remainingTysExpSubst' :: [Type] + remainingTysExpSubst' = + map (substNamesWithKindStar kvNames') remainingTysExpSubst + + -- We now substitute all of the specialized-to-* kind variable names with + -- *, but in the original types, not the synonym-expanded types. The reason + -- we do this is a superficial one: we want the derived instance to resemble + -- the datatype written in source code as closely as possible. For example, + -- for the following data family instance: + -- + -- data family Fam a + -- newtype instance Fam String = Fam String + -- + -- We'd want to generate the instance: + -- + -- instance C (Fam String) + -- + -- Not: + -- + -- instance C (Fam [Char]) + remainingTysOrigSubst :: [Type] + remainingTysOrigSubst = + map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) + $ take remainingLength instTysOrig + + isDataFamily <- + case variant of + Datatype -> return False + Newtype -> return False + DataInstance -> return True + NewtypeInstance -> return True +#if MIN_VERSION_th_abstraction(0,5,0) + Datatype.TypeData -> typeDataError tyConName +#endif + + let remainingTysOrigSubst' :: [Type] + -- See Note [Kind signatures in derived instances] for an explanation + -- of the isDataFamily check. + remainingTysOrigSubst' = + if isDataFamily + then remainingTysOrigSubst + else map unSigT remainingTysOrigSubst + + instanceCxt :: Cxt + instanceCxt = catMaybes preds + + instanceType :: Type + instanceType = AppT (ConT $ biClassName biClass) + $ applyTyCon tyConName remainingTysOrigSubst' + + -- If the datatype context mentions any of the dropped type variables, + -- we can't derive an instance, so throw an error. + when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ + datatypeContextError tyConName instanceType + -- Also ensure the dropped types can be safely eta-reduced. Otherwise, + -- throw an error. + unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ + etaReductionError instanceType + return (instanceCxt, instanceType) + +-- | Attempt to derive a constraint on a Type. If successful, return +-- Just the constraint and any kind variable names constrained to *. +-- Otherwise, return Nothing and the empty list. +-- +-- See Note [Type inference in derived instances] for the heuristics used to +-- come up with constraints. +deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name]) +deriveConstraint biClass t + | not (isTyVar t) = (Nothing, []) + | otherwise = case hasKindVarChain 1 t of + Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns) + _ -> case hasKindVarChain 2 t of + Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns) + _ -> (Nothing, []) + where + tName :: Name + tName = varTToName t + +{- +Note [Kind signatures in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to put explicit kind signatures into the derived instances, e.g., + + instance C a => C (Data (f :: * -> *)) where ... + +But it is preferable to avoid this if possible. If we come up with an incorrect +kind signature (which is entirely possible, since our type inferencer is pretty +unsophisticated - see Note [Type inference in derived instances]), then GHC will +flat-out reject the instance, which is quite unfortunate. + +Plain old datatypes have the advantage that you can avoid using any kind signatures +at all in their instances. This is because a datatype declaration uses all type +variables, so the types that we use in a derived instance uniquely determine their +kinds. As long as we plug in the right types, the kind inferencer can do the rest +of the work. For this reason, we use unSigT to remove all kind signatures before +splicing in the instance context and head. + +Data family instances are trickier, since a data family can have two instances that +are distinguished by kind alone, e.g., + + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) + +If we dropped the kind signatures for C (Fam a), then GHC will have no way of +knowing which instance we are talking about. To avoid this scenario, we always +include explicit kind signatures in data family instances. There is a chance that +the inferred kind signatures will be incorrect, but if so, we can always fall back +on the make- functions. + +Note [Type inference in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Type inference is can be tricky to get right, and we want to avoid recreating the +entirety of GHC's type inferencer in Template Haskell. For this reason, we will +probably never come up with derived instance contexts that are as accurate as +GHC's. But that doesn't mean we can't do anything! There are a couple of simple +things we can do to make instance contexts that work for 80% of use cases: + +1. If one of the last type parameters is polykinded, then its kind will be + specialized to * in the derived instance. We note what kind variable the type + parameter had and substitute it with * in the other types as well. For example, + imagine you had + + data Data (a :: k) (b :: k) (c :: k) + + Then you'd want to derived instance to be: + + instance C (Data (a :: *)) + + Not: + + instance C (Data (a :: k)) + +2. We naïvely come up with instance constraints using the following criteria: + + (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind + variables), then generate a Functor n constraint, and if k1/k2 are kind + variables, then substitute k1/k2 with * elsewhere in the types. We must + consider the case where they are kind variables because you might have a + scenario like this: + + newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) + = Compose (f (g a b)) + + Which would have a derived Bifunctor instance of: + + instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... + (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are + * or kind variables), then generate a Bifunctor n constraint and perform + kind substitution as in the other case. +-} + +{- +Note [Matching functions with GADT type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When deriving Bifoldable, there is a tricky corner case to consider: + + data Both a b where + BothCon :: x -> x -> Both x x + +Which fold functions should be applied to which arguments of BothCon? We have a +choice, since both the function of type (a -> m) and of type (b -> m) can be +applied to either argument. In such a scenario, the second fold function takes +precedence over the first fold function, so the derived Bifoldable instance would be: + + instance Bifoldable Both where + bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2 + +This is not an arbitrary choice, as this definition ensures that +bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both. +-} + +------------------------------------------------------------------------------- +-- Error messages +------------------------------------------------------------------------------- + +-- | Either the given data type doesn't have enough type variables, or one of +-- the type variables to be eta-reduced cannot realize kind *. +derivingKindError :: BiClass -> Name -> Q a +derivingKindError biClass tyConName = fail + . showString "Cannot derive well-kinded instance of form ‘" + . showString className + . showChar ' ' + . showParen True + ( showString (nameBase tyConName) + . showString " ..." + ) + . showString "‘\n\tClass " + . showString className + . showString " expects an argument of kind * -> * -> *" + $ "" + where + className :: String + className = nameBase $ biClassName biClass + +-- | One of the last two type variables appeared in a contravariant position +-- when deriving Bifoldable or Bitraversable. +contravarianceError :: Name -> Q a +contravarianceError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not use the last type variable(s) in a function argument" + $ "" + +-- | A constructor has a function argument in a derived Bifoldable or Bitraversable +-- instance. +noFunctionsError :: Name -> Q a +noFunctionsError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not contain function types" + $ "" + +-- | The data type has a DatatypeContext which mentions one of the eta-reduced +-- type variables. +datatypeContextError :: Name -> Type -> Q a +datatypeContextError dataName instanceType = fail + . showString "Can't make a derived instance of ‘" + . showString (pprint instanceType) + . showString "‘:\n\tData type ‘" + . showString (nameBase dataName) + . showString "‘ must not have a class context involving the last type argument(s)" + $ "" + +-- | The data type has an existential constraint which mentions one of the +-- eta-reduced type variables. +existentialContextError :: Name -> Q a +existentialContextError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must be truly polymorphic in the last argument(s) of the data type" + $ "" + +-- | The data type mentions one of the n eta-reduced type variables in a place other +-- than the last nth positions of a data type in a constructor's field. +outOfPlaceTyVarError :: Name -> Q a +outOfPlaceTyVarError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must only use its last two type variable(s) within" + . showString " the last two argument(s) of a data type" + $ "" + +-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce +-- function for the criteria it would have to meet). +etaReductionError :: Type -> Q a +etaReductionError instanceType = fail $ + "Cannot eta-reduce to an instance of form \n\tinstance (...) => " + ++ pprint instanceType + +typeDataError :: Name -> Q a +typeDataError dataName = fail + . showString "Cannot derive instance for ‘" + . showString (nameBase dataName) + . showString "‘, which is a ‘type data‘ declaration" + $ "" + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which class is being derived. +data BiClass = Bifunctor | Bifoldable | Bitraversable + +-- | A representation of which function is being generated. +data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse + deriving Eq + +biFunConstName :: BiFun -> Name +biFunConstName Bimap = bimapConstValName +biFunConstName Bifoldr = bifoldrConstValName +biFunConstName BifoldMap = bifoldMapConstValName +biFunConstName Bitraverse = bitraverseConstValName + +biClassName :: BiClass -> Name +biClassName Bifunctor = bifunctorTypeName +biClassName Bifoldable = bifoldableTypeName +biClassName Bitraversable = bitraversableTypeName + +biFunName :: BiFun -> Name +biFunName Bimap = bimapValName +biFunName Bifoldr = bifoldrValName +biFunName BifoldMap = bifoldMapValName +biFunName Bitraverse = bitraverseValName + +biClassToFuns :: BiClass -> [BiFun] +biClassToFuns Bifunctor = [Bimap] +biClassToFuns Bifoldable = [Bifoldr, BifoldMap] +biClassToFuns Bitraversable = [Bitraverse] + +biFunToClass :: BiFun -> BiClass +biFunToClass Bimap = Bifunctor +biFunToClass Bifoldr = Bifoldable +biFunToClass BifoldMap = Bifoldable +biFunToClass Bitraverse = Bitraversable + +biClassConstraint :: BiClass -> Int -> Maybe Name +biClassConstraint Bifunctor 1 = Just functorTypeName +biClassConstraint Bifoldable 1 = Just foldableTypeName +biClassConstraint Bitraversable 1 = Just traversableTypeName +biClassConstraint biClass 2 = Just $ biClassName biClass +biClassConstraint _ _ = Nothing + +fmapArity :: Int -> Name +fmapArity 1 = fmapValName +fmapArity 2 = bimapValName +fmapArity n = arityErr n + +foldrArity :: Int -> Name +foldrArity 1 = foldrValName +foldrArity 2 = bifoldrValName +foldrArity n = arityErr n + +foldMapArity :: Int -> Name +foldMapArity 1 = foldMapValName +foldMapArity 2 = bifoldMapValName +foldMapArity n = arityErr n + +traverseArity :: Int -> Name +traverseArity 1 = traverseValName +traverseArity 2 = bitraverseValName +traverseArity n = arityErr n + +arityErr :: Int -> a +arityErr n = error $ "Unsupported arity: " ++ show n + +allowExQuant :: BiClass -> Bool +allowExQuant Bifoldable = True +allowExQuant _ = False + +biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp +biFunEmptyCase biFun z value = + biFunTrivial emptyCase + (varE pureValName `appE` emptyCase) + biFun z + where + emptyCase :: Q Exp + emptyCase = caseE (varE value) [] + +biFunNoCons :: BiFun -> Name -> Name -> Q Exp +biFunNoCons biFun z value = + biFunTrivial seqAndError + (varE pureValName `appE` seqAndError) + biFun z + where + seqAndError :: Q Exp + seqAndError = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (biFunName biFun)) + +biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp +biFunTrivial bimapE bitraverseE biFun z = go biFun + where + go :: BiFun -> Q Exp + go Bimap = bimapE + go Bifoldr = varE z + go BifoldMap = varE memptyValName + go Bitraverse = bitraverseE + +{- +Note [ft_triv for Bifoldable and Bitraversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose +type does not mention one of the last two type parameters. From this, you might +think that we don't need to implement ft_triv for bifoldr, bifoldMap, or +bitraverse at all, but in fact we do need to. Imagine the following data type: + + data T a b = MkT a (T Int b) + +In a derived Bifoldable T instance, you would generate the following bifoldMap +definition: + + bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 + +You need to fill in bi_triv (\_ -> mempty) as the first argument to the recursive +call to bifoldMap, since that is how the algorithm handles polymorphic recursion. +-} + +------------------------------------------------------------------------------- +-- Generic traversal for functor-like deriving +------------------------------------------------------------------------------- + +-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC. + +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a + -- ^ Does not contain variables + , ft_var :: Name -> a + -- ^ A bare variable + , ft_co_var :: Name -> a + -- ^ A bare variable, contravariantly + , ft_fun :: a -> a -> a + -- ^ Function type + , ft_tup :: TupleSort -> [a] -> a + -- ^ Tuple type. The [a] is the result of folding over the + -- arguments of the tuple. + , ft_ty_app :: [(Type, a)] -> a + -- ^ Type app, variables only in last argument. The [(Type, a)] + -- represents the last argument types. That is, they form the + -- argument parts of @fun_ty arg_ty_1 ... arg_ty_n@. + , ft_bad_app :: a + -- ^ Type app, variable other than in last arguments + , ft_forall :: [TyVarBndrSpec] -> a -> a + -- ^ Forall type + } + +-- Note that in GHC, this function is pure. It must be monadic here since we: +-- +-- (1) Expand type synonyms +-- (2) Detect type family applications +-- +-- Which require reification in Template Haskell, but are pure in Core. +functorLikeTraverse :: forall a. + TyVarMap -- ^ Variables to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> Q a +functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = do ty' <- resolveTypeSynonyms ty + (res, _) <- go False ty' + return res + where + go :: Bool -- Covariant or contravariant context + -> Type + -> Q (a, Bool) -- (result of type a, does type contain var) + go co t@AppT{} + | (ArrowT, [funArg, funRes]) <- unapplyTy t + = do (funArgR, funArgC) <- go (not co) funArg + (funResR, funResC) <- go co funRes + if funArgC || funResC + then return (caseFun funArgR funResR, True) + else trivial + go co t@AppT{} = do + let (f, args) = unapplyTy t + (_, fc) <- go co f + (xrs, xcs) <- fmap unzip $ mapM (go co) args + let numLastArgs, numFirstArgs :: Int + numLastArgs = min 2 $ length args + numFirstArgs = length args - numLastArgs + + tuple :: TupleSort -> Q (a, Bool) + tuple tupSort = return (caseTuple tupSort xrs, True) + + wrongArg :: Q (a, Bool) + wrongArg = return (caseWrongArg, True) + + case () of + _ | not (or xcs) + -> trivial -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | TupleT len <- f + -> tuple $ Boxed len + | UnboxedTupleT len <- f + -> tuple $ Unboxed len + | fc || or (take numFirstArgs xcs) + -> wrongArg -- T (..var..) ty_1 ... ty_n + | otherwise -- T (..no var..) ty_1 ... ty_n + -> do itf <- isInTypeFamilyApp tyVarNames f args + if itf -- We can't decompose type families, so + -- error if we encounter one here. + then wrongArg + else return ( caseTyApp $ drop numFirstArgs $ zip args xrs + , True ) + go co (SigT t k) = do + (_, kc) <- go_kind co k + if kc + then return (caseWrongArg, True) + else go co t + go co (VarT v) + | Map.member v tvMap + = return (if co then caseCoVar v else caseVar v, True) + | otherwise + = trivial + go co (ForallT tvbs _ t) = do + (tr, tc) <- go co t + let tvbNames = map tvName tvbs + if not tc || any (`elem` tvbNames) tyVarNames + then trivial + else return (caseForAll tvbs tr, True) + go _ _ = trivial + + go_kind :: Bool + -> Kind + -> Q (a, Bool) + go_kind = go + + trivial :: Q (a, Bool) + trivial = return (caseTrivial, False) + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + +-- Fold over the arguments of a data constructor in a Functor-like way. +foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a] +foldDataConArgs tvMap ft con = do + fieldTys <- mapM resolveTypeSynonyms $ constructorFields con + mapM foldArg fieldTys + where + foldArg :: Type -> Q a + foldArg = functorLikeTraverse tvMap ft + +-- Make a 'LamE' using a fresh variable. +mkSimpleLam :: (Exp -> Q Exp) -> Q Exp +mkSimpleLam lam = do + -- Use an underscore in front of the variable name, as it's possible for + -- certain Bifoldable instances to generate code like this (see #89): + -- + -- @ + -- bifoldMap (\\_n -> mempty) ... + -- @ + -- + -- Without the underscore, that code would trigger -Wunused-matches warnings. + n <- newName "_n" + lamE [varP n] $ lam (VarE n) + +-- Make a 'LamE' using two fresh variables. +mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp +mkSimpleLam2 lam = do + -- Use an underscore in front of the variable name, as it's possible for + -- certain Bifoldable instances to generate code like this (see #89): + -- + -- @ + -- bifoldr (\\_n1 n2 -> n2) ... + -- @ + -- + -- Without the underscore, that code would trigger -Wunused-matches warnings. + n1 <- newName "_n1" + n2 <- newName "n2" + lamE [varP n1, varP n2] $ lam (VarE n1) (VarE n2) + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +-- +-- @mkSimpleConMatch fold conName insides@ produces a match clause in +-- which the LHS pattern-matches on @extraPats@, followed by a match on the +-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over +-- @conName@ and its arguments, applying an expression (from @insides@) to each +-- of the respective arguments of @conName@. +mkSimpleConMatch :: (Name -> [a] -> Q Exp) + -> Name + -> [Exp -> a] + -> Q Match +mkSimpleConMatch fold conName insides = do + varsNeeded <- newNameList "_arg" $ length insides + let pat = conPCompat conName (map VarP varsNeeded) + rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) + return $ Match pat (NormalB rhs) [] + +-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" +-- +-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to +-- 'mkSimpleConMatch', with two key differences: +-- +-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it +-- filters out the expressions corresponding to arguments whose types do not +-- mention the last type variable in a derived 'Foldable' or 'Traversable' +-- instance (i.e., those elements of @insides@ containing @False@). +-- +-- 2. @fold@ takes an expression as its first argument instead of a +-- constructor name. This is because it uses a specialized +-- constructor function expression that only takes as many parameters as +-- there are argument types that mention the last type variable. +mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) + -> Name + -> [(Bool, Exp)] + -> Q Match +mkSimpleConMatch2 fold conName insides = do + varsNeeded <- newNameList "_arg" lengthInsides + let pat = conPCompat conName (map VarP varsNeeded) + -- Make sure to zip BEFORE invoking catMaybes. We want the variable + -- indices in each expression to match up with the argument indices + -- in conExpr (defined below). + exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) + else Nothing) + insides varsNeeded + -- An element of argTysTyVarInfo is True if the constructor argument + -- with the same index has a type which mentions the last type + -- variable. + argTysTyVarInfo = map (\(m, _) -> m) insides + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded + + conExpQ + | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) + | otherwise = do + bs <- newNameList "b" lengthInsides + let bs' = filterByList argTysTyVarInfo bs + vars = filterByLists argTysTyVarInfo + (map varE bs) (map varE varsNeeded) + lamE (map varP bs') (appsE (conE conName:vars)) + + conExp <- conExpQ + rhs <- fold conExp exps + return $ Match pat (NormalB rhs) [] + where + lengthInsides = length insides + +-- Indicates whether a tuple is boxed or unboxed, as well as its number of +-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) +-- corresponds to @Unboxed 3@. +data TupleSort + = Boxed Int + | Unboxed Int + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: (Name -> [a] -> Q Match) + -> TupleSort -> [a] -> Exp -> Q Exp +mkSimpleTupleCase matchForCon tupSort insides x = do + let tupDataName = case tupSort of + Boxed len -> tupleDataName len + Unboxed len -> unboxedTupleDataName len + m <- matchForCon tupDataName insides + return $ CaseE x [m] + +-- Adapt to the type of ConP changing in template-haskell-2.18.0.0. +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/src/Data/Bifunctor/TH/Internal.hs b/src/Data/Bifunctor/TH/Internal.hs --- a/src/Data/Bifunctor/TH/Internal.hs +++ b/src/Data/Bifunctor/TH/Internal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Unsafe #-} {-| Module: Data.Bifunctor.TH.Internal @@ -11,96 +12,33 @@ -} module Data.Bifunctor.TH.Internal where -import Control.Monad (liftM) - -import Data.Bifunctor (bimap) +import Control.Applicative +import Data.Bifunctor (Bifunctor(..)) +import Data.Bifoldable (Bifoldable(..)) +import Data.Bitraversable (Bitraversable(..)) +import Data.Coerce (coerce) import Data.Foldable (foldr') -import Data.List -import qualified Data.Map as Map (fromList, findWithDefault, singleton) +import qualified Data.List as List +import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid (Dual(..), Endo(..)) import qualified Data.Set as Set import Data.Set (Set) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -#ifndef CURRENT_PACKAGE_KEY -import Data.Version (showVersion) -import Paths_bifunctors (version) -#endif - ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the --- @genifunctors@ package (licensed under BSD3). -expandSyn :: Type -> Q Type -expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t -expandSyn t@AppT{} = expandSynApp t [] -expandSyn t@ConT{} = expandSynApp t [] -expandSyn (SigT t k) = do t' <- expandSyn t - k' <- expandSynKind k - return (SigT t' k') -expandSyn t = return t - -expandSynKind :: Kind -> Q Kind -#if MIN_VERSION_template_haskell(2,8,0) -expandSynKind = expandSyn -#else -expandSynKind = return -- There are no kind synonyms to deal with -#endif - -expandSynApp :: Type -> [Type] -> Q Type -expandSynApp (AppT t1 t2) ts = do - t2' <- expandSyn t2 - expandSynApp t1 (t2':ts) -expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts -expandSynApp t@(ConT n) ts = do - info <- reify n - case info of - TyConI (TySynD _ tvs rhs) -> - let (ts', ts'') = splitAt (length tvs) ts - subs = mkSubst tvs ts' - rhs' = substType subs rhs - in expandSynApp rhs' ts'' - _ -> return $ foldl' AppT t ts -expandSynApp t ts = do - t' <- expandSyn t - return $ foldl' AppT t' ts - -type TypeSubst = Map Name Type -type KindSubst = Map Name Kind - -mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst -mkSubst vs ts = - let vs' = map un vs - un (PlainTV v) = v - un (KindedTV v _) = v - in Map.fromList $ zip vs' ts - -substType :: TypeSubst -> Type -> Type -substType subs (ForallT v c t) = ForallT v c $ substType subs t -substType subs t@(VarT n) = Map.findWithDefault t n subs -substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2) -substType subs (SigT t k) = SigT (substType subs t) -#if MIN_VERSION_template_haskell(2,8,0) - (substType subs k) -#else - k -#endif -substType _ t = t - -substKind :: KindSubst -> Type -> Type -#if MIN_VERSION_template_haskell(2,8,0) -substKind = substType -#else -substKind _ = id -- There are no kind variables! -#endif +applySubstitutionKind :: Map Name Kind -> Type -> Type +applySubstitutionKind = applySubstitution substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = substKind (Map.singleton n k) +substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns @@ -140,9 +78,7 @@ canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of -#if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k -#endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. @@ -160,21 +96,6 @@ -- Assorted utilities ------------------------------------------------------------------------------- --- isRight and fromEither taken from the extra package (BSD3-licensed) - --- | Test if an 'Either' value is the 'Right' constructor. --- Provided as standard with GHC 7.8 and above. -isRight :: Either l r -> Bool -isRight Right{} = True; isRight _ = False - --- | Pull the value out of an 'Either' where both alternatives --- have the same type. --- --- > \x -> fromEither (Left x ) == x --- > \x -> fromEither (Right x) == x -fromEither :: Either a a -> a -fromEither = either id id - -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) -- | 'filterByList' takes a list of Bools and a list of some elements and @@ -216,56 +137,18 @@ go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs go trues falses _ _ = (reverse trues, reverse falses) --- | Apply an @Either Exp Exp@ expression to an 'Exp' expression, --- preserving the 'Either'-ness. -appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp) -appEitherE e1Q e2Q = do - e2 <- e2Q - let e2' :: Exp -> Exp - e2' = (`AppE` e2) - bimap e2' e2' `fmap` e1Q - -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True -#if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True -#else -hasKindStar (SigT _ StarK) = True -#endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool -#if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True -#else -isStarOrVar StarK = True -#endif isStarOrVar _ = False --- | Gets all of the type/kind variable names mentioned somewhere in a Type. -tyVarNamesOfType :: Type -> [Name] -tyVarNamesOfType = go - where - go :: Type -> [Name] - go (AppT t1 t2) = go t1 ++ go t2 - go (SigT t _k) = go t -#if MIN_VERSION_template_haskell(2,8,0) - ++ go _k -#endif - go (VarT n) = [n] - go _ = [] - --- | Gets all of the type/kind variable names mentioned somewhere in a Kind. -tyVarNamesOfKind :: Kind -> [Name] -#if MIN_VERSION_template_haskell(2,8,0) -tyVarNamesOfKind = tyVarNamesOfType -#else -tyVarNamesOfKind _ = [] -- There are no kind variables -#endif - -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. @@ -273,7 +156,7 @@ hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (concatMap tyVarNamesOfKind uk) + then Just (freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. @@ -281,15 +164,6 @@ tyKind (SigT _ k) = k tyKind _ = starK --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. -stealKindForType :: TyVarBndr -> Type -> Type -stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) -stealKindForType _ t = t - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - -- | A mapping of type variable Names to their map function Names. For example, in a -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where -- a and b are the last two type variables of the datatype, and f and g are the two @@ -299,38 +173,19 @@ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c --- | Extracts the name of a constructor. -constructorName :: Con -> Name -constructorName (NormalC name _ ) = name -constructorName (RecC name _ ) = name -constructorName (InfixC _ name _ ) = name -constructorName (ForallC _ _ con) = constructorName con -#if MIN_VERSION_template_haskell(2,11,0) -constructorName (GadtC names _ _) = head names -constructorName (RecGadtC names _ _) = head names -#endif +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = case unsnoc xs of + Nothing -> Just ([], x) + Just (a,b) -> Just (x:a, b) -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] --- | Extracts the kind from a TyVarBndr. -tvbKind :: TyVarBndr -> Kind -tvbKind (PlainTV _) = starK -tvbKind (KindedTV _ k) = k - --- | Convert a TyVarBndr to a Type. -tvbToType :: TyVarBndr -> Type -tvbToType (PlainTV n) = VarT n -tvbToType (KindedTV n k) = SigT (VarT n) k - -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred -#if MIN_VERSION_template_haskell(2,10,0) applyClass con t = AppT (ConT con) (VarT t) -#else -applyClass con t = ClassP con [VarT t] -#endif -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions: @@ -371,23 +226,37 @@ isTyVar (SigT t _) = isTyVar t isTyVar _ = False --- | Is the given type a type family constructor (and not a data family constructor)? -isTyFamily :: Type -> Q Bool -isTyFamily (ConT n) = do - info <- reify n - return $ case info of -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI OpenTypeFamilyD{} _ -> True -#elif MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD TypeFam _ _ _) _ -> True -#else - TyConI (FamilyD TypeFam _ _ _) -> True -#endif -#if MIN_VERSION_template_haskell(2,9,0) - FamilyI ClosedTypeFamilyD{} _ -> True -#endif - _ -> False -isTyFamily _ = return False +-- | Detect if a Name in a list of provided Names occurs as an argument to some +-- type family. This makes an effort to exclude /oversaturated/ arguments to +-- type families. For instance, if one declared the following type family: +-- +-- @ +-- type family F a :: Type -> Type +-- @ +-- +-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, +-- but not @b@. +isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool +isInTypeFamilyApp names tyFun tyArgs = + case tyFun of + ConT tcName -> go tcName + _ -> return False + where + go :: Name -> Q Bool + go tcName = do + info <- reify tcName + case info of + FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ + -> withinFirstArgs bndrs + FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ + -> withinFirstArgs bndrs + _ -> return False + where + withinFirstArgs :: [a] -> Q Bool + withinFirstArgs bndrs = + let firstArgs = take (length bndrs) tyArgs + argFVs = freeVariables firstArgs + in return $ any (`elem` argFVs) names -- | Are all of the items in a list (which have an ordering) distinct? -- @@ -407,25 +276,17 @@ where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names - go (SigT t _k) names = go t names -#if MIN_VERSION_template_haskell(2,8,0) - || go _k names -#endif + go (SigT t k) names = go t names || go k names go (VarT n) names = n `elem` names go _ _ = False -- | Does an instance predicate mention any of the Names in the list? predMentionsName :: Pred -> [Name] -> Bool -#if MIN_VERSION_template_haskell(2,10,0) predMentionsName = mentionsName -#else -predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys -predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names -#endif -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type -applyTy = foldl' AppT +applyTy = List.foldl' AppT -- | Fully applies a type constructor to its type variables. applyTyCon :: Name -> [Type] -> Type @@ -442,14 +303,15 @@ -- @ -- [Either, Int, Char] -- @ -unapplyTy :: Type -> [Type] -unapplyTy = reverse . go +unapplyTy :: Type -> (Type, [Type]) +unapplyTy ty = go ty ty [] where - go :: Type -> [Type] - go (AppT t1 t2) = t2:go t1 - go (SigT t _) = go t - go (ForallT _ _ t) = go t - go t = [t] + go :: Type -> Type -> [Type] -> (Type, [Type]) + go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) + go origTy (SigT ty' _) args = go origTy ty' args + go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args + go origTy (ParensT ty') args = go origTy ty' args + go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this: -- @@ -474,151 +336,113 @@ -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind] -#if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy -#else -uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 -uncurryKind k = [k] -#endif ------------------------------------------------------------------------------- --- Manually quoted names +-- Quoted names ------------------------------------------------------------------------------- --- By manually generating these names we avoid needing to use the --- TemplateHaskell language extension when compiling the bifunctors library. --- This allows the library to be used in stage1 cross-compilers. - -bifunctorsPackageKey :: String -#ifdef CURRENT_PACKAGE_KEY -bifunctorsPackageKey = CURRENT_PACKAGE_KEY -#else -bifunctorsPackageKey = "bifunctors-" ++ showVersion version -#endif - -mkBifunctorsName_tc :: String -> String -> Name -mkBifunctorsName_tc = mkNameG_tc bifunctorsPackageKey - -mkBifunctorsName_v :: String -> String -> Name -mkBifunctorsName_v = mkNameG_v bifunctorsPackageKey - -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" - bimapConstValName :: Name -bimapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bimapConst" +bimapConstValName = 'bimapConst bifoldrConstValName :: Name -bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst" +bifoldrConstValName = 'bifoldrConst bifoldMapConstValName :: Name -bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst" - -bitraverseConstValName :: Name -bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" +bifoldMapConstValName = 'bifoldMapConst -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" +coerceValName :: Name +coerceValName = 'coerce -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" +bitraverseConstValName :: Name +bitraverseConstValName = 'bitraverseConst wrapMonadDataName :: Name -wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" +wrapMonadDataName = 'WrapMonad functorTypeName :: Name -functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" +functorTypeName = ''Functor foldableTypeName :: Name -foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" +foldableTypeName = ''Foldable traversableTypeName :: Name -traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" - -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" +traversableTypeName = ''Traversable composeValName :: Name -composeValName = mkNameG_v "base" "GHC.Base" "." +composeValName = '(.) idValName :: Name -idValName = mkNameG_v "base" "GHC.Base" "id" +idValName = 'id errorValName :: Name -errorValName = mkNameG_v "base" "GHC.Err" "error" +errorValName = 'error flipValName :: Name -flipValName = mkNameG_v "base" "GHC.Base" "flip" +flipValName = 'flip fmapValName :: Name -fmapValName = mkNameG_v "base" "GHC.Base" "fmap" +fmapValName = 'fmap foldrValName :: Name -foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" +foldrValName = 'foldr foldMapValName :: Name -foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" +foldMapValName = 'foldMap -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" +seqValName :: Name +seqValName = 'seq traverseValName :: Name -traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" +traverseValName = 'traverse unwrapMonadValName :: Name -unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" - -#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0)) -starKindName :: Name -starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" -#endif +unwrapMonadValName = 'unwrapMonad -#if MIN_VERSION_base(4,8,0) bifunctorTypeName :: Name -bifunctorTypeName = mkNameG_tc "base" "Data.Bifunctor" "Bifunctor" +bifunctorTypeName = ''Bifunctor bimapValName :: Name -bimapValName = mkNameG_v "base" "Data.Bifunctor" "bimap" +bimapValName = 'bimap pureValName :: Name -pureValName = mkNameG_v "base" "GHC.Base" "pure" +pureValName = 'pure apValName :: Name -apValName = mkNameG_v "base" "GHC.Base" "<*>" +apValName = '(<*>) +liftA2ValName :: Name +liftA2ValName = 'liftA2 + mappendValName :: Name -mappendValName = mkNameG_v "base" "GHC.Base" "mappend" +mappendValName = 'mappend memptyValName :: Name -memptyValName = mkNameG_v "base" "GHC.Base" "mempty" -#else -bifunctorTypeName :: Name -bifunctorTypeName = mkBifunctorsName_tc "Data.Bifunctor" "Bifunctor" +memptyValName = 'mempty -bimapValName :: Name -bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap" +bifoldableTypeName :: Name +bifoldableTypeName = ''Bifoldable -pureValName :: Name -pureValName = mkNameG_v "base" "Control.Applicative" "pure" +bitraversableTypeName :: Name +bitraversableTypeName = ''Bitraversable -apValName :: Name -apValName = mkNameG_v "base" "Control.Applicative" "<*>" +bifoldrValName :: Name +bifoldrValName = 'bifoldr -mappendValName :: Name -mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" +bifoldMapValName :: Name +bifoldMapValName = 'bifoldMap -memptyValName :: Name -memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" -#endif +bitraverseValName :: Name +bitraverseValName = 'bitraverse + +appEndoValName :: Name +appEndoValName = 'appEndo + +dualDataName :: Name +dualDataName = 'Dual + +endoDataName :: Name +endoDataName = 'Endo + +getDualValName :: Name +getDualValName = 'getDual diff --git a/src/Data/Bifunctor/Tannen.hs b/src/Data/Bifunctor/Tannen.hs --- a/src/Data/Bifunctor/Tannen.hs +++ b/src/Data/Bifunctor/Tannen.hs @@ -1,19 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett @@ -36,62 +29,53 @@ import Data.Bifunctor as B import Data.Bifunctor.Functor +import Data.Bifunctor.Swap (Swap (..)) import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif +import Data.Foldable1 (Foldable1(..)) +import Data.Functor.Classes -#if __GLASGOW_HASKELL__ >= 702 import GHC.Generics -#endif import Prelude hiding ((.),id) -- | Compose a 'Functor' on the outside of a 'Bifunctor'. newtype Tannen f p a b = Tannen { runTannen :: f (p a b) } - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Typeable -#endif - ) -#if __GLASGOW_HASKELL__ >= 702 -# if __GLASGOW_HASKELL__ >= 708 + deriving (Eq, Ord, Show, Read, Generic) deriving instance Functor f => Generic1 (Tannen f p a) -# else -data TannenMetaData -data TannenMetaCons -data TannenMetaSel -instance Datatype TannenMetaData where - datatypeName _ = "Tannen" - moduleName _ = "Data.Bifunctor.Tannen" +instance (Eq1 f, Eq2 p, Eq a) => Eq1 (Tannen f p a) where + liftEq = liftEq2 (==) +instance (Eq1 f, Eq2 p) => Eq2 (Tannen f p) where + liftEq2 f g (Tannen x) (Tannen y) = liftEq (liftEq2 f g) x y -instance Constructor TannenMetaCons where - conName _ = "Tannen" - conIsRecord _ = True +instance (Ord1 f, Ord2 p, Ord a) => Ord1 (Tannen f p a) where + liftCompare = liftCompare2 compare +instance (Ord1 f, Ord2 p) => Ord2 (Tannen f p) where + liftCompare2 f g (Tannen x) (Tannen y) = liftCompare (liftCompare2 f g) x y -instance Selector TannenMetaSel where - selName _ = "runTannen" +instance (Read1 f, Read2 p, Read a) => Read1 (Tannen f p a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Read1 f, Read2 p) => Read2 (Tannen f p) where + liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do + ("Tannen", s1) <- lex s0 + ("{", s2) <- lex s1 + ("runTannen", s3) <- lex s2 + (x, s4) <- liftReadsPrec (liftReadsPrec2 rp1 rl1 rp2 rl2) + (liftReadList2 rp1 rl1 rp2 rl2) 0 s3 + ("}", s5) <- lex s4 + return (Tannen x, s5) -instance Functor f => Generic1 (Tannen f p a) where - type Rep1 (Tannen f p a) = D1 TannenMetaData (C1 TannenMetaCons - (S1 TannenMetaSel (f :.: Rec1 (p a)))) - from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runTannen - to1 = Tannen . fmap unRec1 . unComp1 . unM1 . unM1 . unM1 -# endif -#endif +instance (Show1 f, Show2 p, Show a) => Show1 (Tannen f p a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Show1 f, Show2 p) => Show2 (Tannen f p) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (Tannen x) = showParen (p > 10) $ + showString "Tannen {runTannen = " + . liftShowsPrec (liftShowsPrec2 sp1 sl1 sp2 sl2) + (liftShowList2 sp1 sl1 sp2 sl2) 0 x + . showChar '}' instance Functor f => BifunctorFunctor (Tannen f) where bifmap f (Tannen fp) = Tannen (fmap f fp) @@ -131,6 +115,10 @@ bifoldMap f g = foldMap (bifoldMap f g) . runTannen {-# INLINE bifoldMap #-} +instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where + bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen + {-# INLINE bifoldMap1 #-} + instance (Traversable f, Bitraversable p) => Traversable (Tannen f p a) where traverse f = fmap Tannen . traverse (bitraverse pure f) . runTannen {-# INLINE traverse #-} @@ -165,3 +153,6 @@ instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g) +-- | @since 5.6.1 +instance (Functor f, Swap p) => Swap (Tannen f p) where + swap = Tannen . fmap swap . runTannen diff --git a/src/Data/Bifunctor/Wrapped.hs b/src/Data/Bifunctor/Wrapped.hs --- a/src/Data/Bifunctor/Wrapped.hs +++ b/src/Data/Bifunctor/Wrapped.hs @@ -1,15 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -25,63 +18,45 @@ ( WrappedBifunctor(..) ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Data.Biapplicative import Data.Bifoldable +import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable - -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Monoid -import Data.Traversable -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - -#if __GLASGOW_HASKELL__ >= 702 +import Data.Functor.Classes import GHC.Generics -#endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. newtype WrappedBifunctor p a b = WrapBifunctor { unwrapBifunctor :: p a b } - deriving ( Eq, Ord, Show, Read -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Generic1 - , Typeable -#endif - ) - -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 -data WrappedBifunctorMetaData -data WrappedBifunctorMetaCons -data WrappedBifunctorMetaSel + deriving (Eq, Ord, Show, Read, Generic, Generic1) -instance Datatype WrappedBifunctorMetaData where - datatypeName = const "WrappedBifunctor" - moduleName = const "Data.Bifunctor.Wrapped" +instance (Eq2 p, Eq a) => Eq1 (WrappedBifunctor p a) where + liftEq = liftEq2 (==) +instance Eq2 p => Eq2 (WrappedBifunctor p) where + liftEq2 f g (WrapBifunctor x) (WrapBifunctor y) = liftEq2 f g x y -instance Constructor WrappedBifunctorMetaCons where - conName = const "WrapBifunctor" - conIsRecord = const True +instance (Ord2 p, Ord a) => Ord1 (WrappedBifunctor p a) where + liftCompare = liftCompare2 compare +instance Ord2 p => Ord2 (WrappedBifunctor p) where + liftCompare2 f g (WrapBifunctor x) (WrapBifunctor y) = liftCompare2 f g x y -instance Selector WrappedBifunctorMetaSel where - selName = const "unwrapBifunctor" +instance (Read2 p, Read a) => Read1 (WrappedBifunctor p a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance Read2 p => Read2 (WrappedBifunctor p) where + liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do + ("WrapBifunctor", s1) <- lex s0 + ("{", s2) <- lex s1 + ("unwrapBifunctor", s3) <- lex s2 + (x, s4) <- liftReadsPrec2 rp1 rl1 rp2 rl2 0 s3 + ("}", s5) <- lex s4 + return (WrapBifunctor x, s5) -instance Generic1 (WrappedBifunctor p a) where - type Rep1 (WrappedBifunctor p a) = D1 WrappedBifunctorMetaData - (C1 WrappedBifunctorMetaCons - (S1 WrappedBifunctorMetaSel (Rec1 (p a)))) - from1 = M1 . M1 . M1 . Rec1 . unwrapBifunctor - to1 = WrapBifunctor . unRec1 . unM1 . unM1 . unM1 -#endif +instance (Show2 p, Show a) => Show1 (WrappedBifunctor p a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show2 p => Show2 (WrappedBifunctor p) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (WrapBifunctor x) = showParen (p > 10) $ + showString "WrapBifunctor {unwrapBifunctor = " + . liftShowsPrec2 sp1 sl1 sp2 sl2 0 x + . showChar '}' instance Bifunctor p => Bifunctor (WrappedBifunctor p) where first f = WrapBifunctor . first f . unwrapBifunctor @@ -108,6 +83,10 @@ instance Bifoldable p => Bifoldable (WrappedBifunctor p) where bifoldMap f g = bifoldMap f g . unwrapBifunctor {-# INLINE bifoldMap #-} + +instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where + bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor + {-# INLINE bifoldMap1 #-} instance Bitraversable p => Traversable (WrappedBifunctor p a) where traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor diff --git a/src/Data/Bitraversable.hs b/src/Data/Bitraversable.hs deleted file mode 100644 --- a/src/Data/Bitraversable.hs +++ /dev/null @@ -1,299 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} - -#ifndef MIN_VERSION_semigroups -#define MIN_VERSION_semigroups(x,y,z) 0 -#endif ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2011-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- 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.Orphans () - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) -import Data.Semigroup (Arg(..)) -#endif - -#ifdef MIN_VERSION_tagged -import Data.Tagged -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (K1(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -import Data.Typeable -#endif - --- | 'Bitraversable' identifies bifunctorial data structures whose elements can --- be traversed in order, performing 'Applicative' or 'Monad' actions at each --- element, and collecting a result structure with the same shape. --- --- A definition of 'traverse' must satisfy the following laws: --- --- [/naturality/] --- @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@ --- for every applicative transformation @t@ --- --- [/identity/] --- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ --- --- [/composition/] --- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2 --- ≡ 'traverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@ --- --- where an /applicative transformation/ is a function --- --- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@ --- --- preserving the 'Applicative' operations: --- --- @ --- t ('pure' x) = 'pure' x --- t (f '<*>' x) = t f '<*>' t x --- @ --- --- and the identity functor 'Identity' and composition functors 'Compose' are --- defined as --- --- > newtype Identity a = Identity { runIdentity :: a } --- > --- > instance Functor Identity where --- > fmap f (Identity x) = Identity (f x) --- > --- > instance Applicative Identity where --- > pure = Identity --- > Identity f <*> Identity x = Identity (f x) --- > --- > newtype Compose f g a = Compose (f (g a)) --- > --- > instance (Functor f, Functor g) => Functor (Compose f g) where --- > fmap f (Compose x) = Compose (fmap (fmap f) x) --- > --- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where --- > pure = Compose . pure . pure --- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) --- --- Some simple examples are 'Either' and '(,)': --- --- > instance Bitraversable Either where --- > bitraverse f _ (Left x) = Left <$> f x --- > bitraverse _ g (Right y) = Right <$> g y --- > --- > instance Bitraversable (,) where --- > bitraverse f g (x, y) = (,) <$> f x <*> g y --- --- 'Bitraversable' relates to its superclasses in the following ways: --- --- @ --- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g) --- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g) --- @ --- --- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively. -class (Bifunctor t, Bifoldable t) => Bitraversable t where - -- | Evaluates the relevant functions at each element in the structure, running - -- the action, and builds a new structure with the same shape, using the - -- elements produced from sequencing the actions. - -- - -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@ - bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) - bitraverse f g = bisequenceA . bimap f g - {-# INLINE bitraverse #-} - - --- | Sequences all the actions in a structure, building a new structure with the --- same shape using the results of the actions. --- --- @'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'. --- --- @ --- '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'. --- --- @ --- 'bisequence' ≡ 'bimapM' 'id' 'id' --- 'bisequence' ≡ 'unwrapMonad' . 'bisequenceA' . 'bimap' 'WrapMonad' 'WrapMonad' --- @ -bisequence :: (Bitraversable t, Monad m) => t (m a) (m b) -> m (t a b) -bisequence = bimapM id id -{-# INLINE bisequence #-} - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -deriving instance Typeable Bitraversable -#endif - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) -instance Bitraversable Arg where - bitraverse f g (Arg a b) = Arg <$> f a <*> g b -#endif - -instance Bitraversable (,) where - bitraverse f g ~(a, b) = (,) <$> f a <*> g b - {-# INLINE bitraverse #-} - -instance Bitraversable ((,,) x) where - bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b - {-# INLINE bitraverse #-} - -instance Bitraversable ((,,,) x y) where - bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b - {-# INLINE bitraverse #-} - -instance Bitraversable ((,,,,) x y z) where - bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b - {-# INLINE bitraverse #-} - -instance Bitraversable ((,,,,,) x y z w) where - bitraverse f g ~(x, y, z, w, a, b) = (,,,,,) x y z w <$> f a <*> g b - {-# INLINE bitraverse #-} - -instance Bitraversable ((,,,,,,) x y z w v) where - bitraverse f g ~(x, y, z, w, v, a, b) = (,,,,,,) x y z w v <$> f a <*> g b - {-# INLINE bitraverse #-} - -instance Bitraversable Either where - bitraverse f _ (Left a) = Left <$> f a - bitraverse _ g (Right b) = Right <$> g b - {-# INLINE bitraverse #-} - -instance Bitraversable Const where - bitraverse f _ (Const a) = Const <$> f a - {-# INLINE bitraverse #-} - -instance Bitraversable Constant where - bitraverse f _ (Constant a) = Constant <$> f a - {-# INLINE bitraverse #-} - -#if __GLASGOW_HASKELL__ >= 702 -instance Bitraversable (K1 i) where - bitraverse f _ (K1 c) = K1 <$> f c - {-# INLINE bitraverse #-} -#endif - -#ifdef MIN_VERSION_tagged -instance Bitraversable Tagged where - bitraverse _ g (Tagged b) = Tagged <$> g b - {-# INLINE bitraverse #-} -#endif - --- | 'bifor' is 'bitraverse' with the structure as the first argument. -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. -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 (<*>) #-} - --- | 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 (<*>) #-} - --- | 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 #-} - -newtype Id a = Id { getId :: a } - -instance Functor Id where - fmap f (Id x) = Id (f x) - {-# INLINE fmap #-} - -instance Applicative Id where - pure = Id - {-# INLINE pure #-} - Id f <*> Id x = Id (f x) - {-# INLINE (<*>) #-} - --- | A default definition of 'bimap' in terms of the 'Bitraversable' operations. -bimapDefault :: Bitraversable t => (a -> b) -> (c -> d) -> t a c -> t b d -bimapDefault f g = getId . bitraverse (Id . f) (Id . g) -{-# INLINE bimapDefault #-} - --- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' operations. -bifoldMapDefault :: (Bitraversable t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m -bifoldMapDefault f g = getConst . bitraverse (Const . f) (Const . g) -{-# INLINE bifoldMapDefault #-} diff --git a/tests/BifunctorSpec.hs b/tests/BifunctorSpec.hs --- a/tests/BifunctorSpec.hs +++ b/tests/BifunctorSpec.hs @@ -1,19 +1,26 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-unused-foralls #-} -#endif +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-unused-foralls #-} + {-| Module: BifunctorSpec Copyright: (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott @@ -31,7 +38,7 @@ import Data.Bitraversable import Data.Char (chr) -import Data.Functor.Classes (Eq1) +import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Monoid @@ -42,12 +49,6 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary) -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative (Applicative(..)) -import Data.Foldable (Foldable) -import Data.Traversable (Traversable) -#endif - ------------------------------------------------------------------------------- -- Adapted from the test cases from @@ -61,6 +62,7 @@ | T3 [[a]] [[b]] [[c]] -- nested lists | T4 (c,(b,b),(c,c)) -- tuples | T5 ([c],Strange a b c) -- tycons + deriving (Functor, Foldable, Traversable) type IntFun a b = (b -> Int) -> a data StrangeFunctions a b c @@ -68,6 +70,7 @@ | T7 (a -> (c,a)) -- functions and tuples | T8 ((b -> a) -> c) -- continuation | T9 (IntFun b c) -- type synonyms + deriving Functor data StrangeGADT a b where T10 :: Ord d => d -> StrangeGADT c d @@ -76,35 +79,101 @@ T13 :: i ~ Int => Int -> StrangeGADT h i T14 :: k ~ Int => k -> StrangeGADT j k T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n +instance Foldable (StrangeGADT a) where + foldMap f (T10 x) = f x + foldMap f (T11 _) = mempty + foldMap f (T12 _) = mempty + foldMap f (T13 _) = mempty + foldMap f (T14 x) = f x + foldMap f (T15 _ _) = mempty data NotPrimitivelyRecursive a b = S1 (NotPrimitivelyRecursive (a,a) (b, a)) | S2 a | S3 b + deriving (Functor, Foldable, Traversable) newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b)) - deriving (Arbitrary, Eq, Show) + deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable) newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) +instance (Bifunctor (f Int), Functor g) => + Functor (ComplexConstraint f g a) where + fmap f (ComplexConstraint x) = + ComplexConstraint (bimap id (\(ga,a,b) -> (ga,a,f b)) x) +instance (Bifoldable (f Int), Foldable g) => + Foldable (ComplexConstraint f g a) where + foldMap f (ComplexConstraint x) = + bifoldMap (const mempty) (\(_,_,b) -> f b) x +instance (Bitraversable (f Int), Traversable g) => + Traversable (ComplexConstraint f g a) where + traverse f (ComplexConstraint x) = + ComplexConstraint `fmap` bitraverse pure (\(ga,a,b) -> (ga,a,) `fmap` f b) x data Universal a b = Universal (forall b. (b,[a])) | Universal2 (forall f. Bifunctor f => f a b) | Universal3 (forall a. Maybe a) -- reuse a | NotReallyUniversal (forall b. a) +instance Functor (Universal a) where + fmap f (Universal x) = Universal x + fmap f (Universal2 x) = Universal2 (bimap id f x) + fmap f (Universal3 x) = Universal3 x + fmap f (NotReallyUniversal x) = NotReallyUniversal x data Existential a b = forall a. ExistentialList [a] | forall f. Bitraversable f => ExistentialFunctor (f a b) | forall b. SneakyUseSameName (Maybe b) +instance Functor (Existential a) where + fmap f (ExistentialList x) = ExistentialList x + fmap f (ExistentialFunctor x) = ExistentialFunctor (bimap id f x) + fmap f (SneakyUseSameName x) = SneakyUseSameName x +instance Foldable (Existential a) where + foldMap f (ExistentialList _) = mempty + foldMap f (ExistentialFunctor x) = bifoldMap (const mempty) f x + foldMap f (SneakyUseSameName _) = mempty +instance Traversable (Existential a) where + traverse f (ExistentialList x) = pure $ ExistentialList x + traverse f (ExistentialFunctor x) = ExistentialFunctor `fmap` bitraverse pure f x + traverse f (SneakyUseSameName x) = pure $ SneakyUseSameName x data IntHash a b = IntHash Int# Int# | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) + deriving (Functor, Foldable) +instance Traversable (IntHash a) where + traverse f (IntHash x y) = pure (IntHash x y) + traverse f (IntHashTuple x y z (a,b,c,d)) = + (\z' b' d' -> IntHashTuple x y z' (a,b',c,d')) + `fmap` f z + <*> f b + <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) + deriving Functor +data Empty1 a b + deriving (Functor, Foldable, Traversable) + +data Empty2 a b + deriving (Functor, Foldable, Traversable) +type role Empty2 nominal nominal + +data TyCon81 a b + = TyCon81a (forall c. c -> (forall d. a -> d) -> a) + | TyCon81b (Int -> forall c. c -> b) +instance Functor (TyCon81 a) where + fmap f (TyCon81a g) = TyCon81a g + fmap f (TyCon81b g) = TyCon81b (\x y -> f (g x y)) + +type family F :: * -> * -> * +type instance F = Either + +data TyCon82 a b = TyCon82 (F a b) + deriving (Functor, Foldable, Traversable) + -- Data families data family StrangeFam x y z @@ -114,6 +183,7 @@ | T3Fam [[a]] [[b]] [[c]] -- nested lists | T4Fam (c,(b,b),(c,c)) -- tuples | T5Fam ([c],Strange a b c) -- tycons + deriving (Functor, Foldable, Traversable) data family StrangeFunctionsFam x y z data instance StrangeFunctionsFam a b c @@ -121,6 +191,7 @@ | T7Fam (a -> (c,a)) -- functions and tuples | T8Fam ((b -> a) -> c) -- continuation | T9Fam (IntFun b c) -- type synonyms + deriving Functor data family StrangeGADTFam x y data instance StrangeGADTFam a b where @@ -130,19 +201,41 @@ T13Fam :: i ~ Int => Int -> StrangeGADTFam h i T14Fam :: k ~ Int => k -> StrangeGADTFam j k T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n +instance Foldable (StrangeGADTFam a) where + foldMap f (T10Fam x) = f x + foldMap f (T11Fam _) = mempty + foldMap f (T12Fam _) = mempty + foldMap f (T13Fam _) = mempty + foldMap f (T14Fam x) = f x + foldMap f (T15Fam _ _) = mempty data family NotPrimitivelyRecursiveFam x y data instance NotPrimitivelyRecursiveFam a b = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) | S2Fam a | S3Fam b + deriving (Functor, Foldable, Traversable) data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b)) - deriving (Arbitrary, Eq, Show) + deriving ( Arbitrary, Eq, Show + , Functor, Foldable, Traversable + ) data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) +instance (Bifunctor (f Int), Functor g) => + Functor (ComplexConstraintFam f g a) where + fmap f (ComplexConstraintFam x) = + ComplexConstraintFam (bimap id (\(ga,a,b) -> (ga,a,f b)) x) +instance (Bifoldable (f Int), Foldable g) => + Foldable (ComplexConstraintFam f g a) where + foldMap f (ComplexConstraintFam x) = + bifoldMap (const mempty) (\(_,_,b) -> f b) x +instance (Bitraversable (f Int), Traversable g) => + Traversable (ComplexConstraintFam f g a) where + traverse f (ComplexConstraintFam x) = + ComplexConstraintFam `fmap` bitraverse pure (\(ga,a,b) -> (ga,a,) `fmap` f b) x data family UniversalFam x y data instance UniversalFam a b @@ -150,22 +243,53 @@ | Universal2Fam (forall f. Bifunctor f => f a b) | Universal3Fam (forall a. Maybe a) -- reuse a | NotReallyUniversalFam (forall b. a) +instance Functor (UniversalFam a) where + fmap f (UniversalFam x) = UniversalFam x + fmap f (Universal2Fam x) = Universal2Fam (bimap id f x) + fmap f (Universal3Fam x) = Universal3Fam x + fmap f (NotReallyUniversalFam x) = NotReallyUniversalFam x data family ExistentialFam x y data instance ExistentialFam a b = forall a. ExistentialListFam [a] | forall f. Bitraversable f => ExistentialFunctorFam (f a b) | forall b. SneakyUseSameNameFam (Maybe b) +instance Functor (ExistentialFam a) where + fmap f (ExistentialListFam x) = ExistentialListFam x + fmap f (ExistentialFunctorFam x) = ExistentialFunctorFam (bimap id f x) + fmap f (SneakyUseSameNameFam x) = SneakyUseSameNameFam x +instance Foldable (ExistentialFam a) where + foldMap f (ExistentialListFam _) = mempty + foldMap f (ExistentialFunctorFam x) = bifoldMap (const mempty) f x + foldMap f (SneakyUseSameNameFam _) = mempty +instance Traversable (ExistentialFam a) where + traverse f (ExistentialListFam x) = pure $ ExistentialListFam x + traverse f (ExistentialFunctorFam x) = ExistentialFunctorFam `fmap` bitraverse pure f x + traverse f (SneakyUseSameNameFam x) = pure $ SneakyUseSameNameFam x data family IntHashFam x y data instance IntHashFam a b = IntHashFam Int# Int# | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) + deriving (Functor, Foldable, Traversable) data family IntHashFunFam x y data instance IntHashFunFam a b = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) + deriving Functor +data family TyFamily81 x y +data instance TyFamily81 a b + = TyFamily81a (forall c. c -> (forall d. a -> d) -> a) + | TyFamily81b (Int -> forall c. c -> b) +instance Functor (TyFamily81 a) where + fmap f (TyFamily81a g) = TyFamily81a g + fmap f (TyFamily81b g) = TyFamily81b (\x y -> f (g x y)) + +data family TyFamily82 x y +data instance TyFamily82 a b = TyFamily82 (F a b) + deriving (Functor, Foldable, Traversable) + ------------------------------------------------------------------------------- -- Plain data types @@ -188,14 +312,31 @@ instance (Bifunctor (f Int), Functor g) => Bifunctor (ComplexConstraint f g) where bimap = $(makeBimap ''ComplexConstraint) + instance (Bifoldable (f Int), Foldable g) => Bifoldable (ComplexConstraint f g) where bifoldr = $(makeBifoldr ''ComplexConstraint) bifoldMap = $(makeBifoldMap ''ComplexConstraint) + +bifoldlComplexConstraint + :: (Bifoldable (f Int), Foldable g) + => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraint f g a b -> c +bifoldlComplexConstraint = $(makeBifoldl ''ComplexConstraint) + +bifoldComplexConstraint + :: (Bifoldable (f Int), Foldable g, Monoid m) + => ComplexConstraint f g m m -> m +bifoldComplexConstraint = $(makeBifold ''ComplexConstraint) + instance (Bitraversable (f Int), Traversable g) => Bitraversable (ComplexConstraint f g) where bitraverse = $(makeBitraverse ''ComplexConstraint) +bisequenceAComplexConstraint + :: (Bitraversable (f Int), Traversable g, Applicative t) + => ComplexConstraint f g (t a) (t b) -> t (ComplexConstraint f g a b) +bisequenceAComplexConstraint = $(makeBisequenceA ''ComplexConstraint) + $(deriveBifunctor ''Universal) $(deriveBifunctor ''Existential) @@ -208,7 +349,21 @@ $(deriveBifunctor ''IntHashFun) -#if MIN_VERSION_template_haskell(2,7,0) +$(deriveBifunctor ''Empty1) +$(deriveBifoldable ''Empty1) +$(deriveBitraversable ''Empty1) + +-- Use EmptyCase here +$(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) + +$(deriveBifunctor ''TyCon81) + +$(deriveBifunctor ''TyCon82) +$(deriveBifoldable ''TyCon82) +$(deriveBitraversable ''TyCon82) + -- Data families $(deriveBifunctor 'T1Fam) @@ -229,14 +384,31 @@ instance (Bifunctor (f Int), Functor g) => Bifunctor (ComplexConstraintFam f g) where bimap = $(makeBimap 'ComplexConstraintFam) + instance (Bifoldable (f Int), Foldable g) => Bifoldable (ComplexConstraintFam f g) where bifoldr = $(makeBifoldr 'ComplexConstraintFam) bifoldMap = $(makeBifoldMap 'ComplexConstraintFam) + +bifoldlComplexConstraintFam + :: (Bifoldable (f Int), Foldable g) + => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraintFam f g a b -> c +bifoldlComplexConstraintFam = $(makeBifoldl 'ComplexConstraintFam) + +bifoldComplexConstraintFam + :: (Bifoldable (f Int), Foldable g, Monoid m) + => ComplexConstraintFam f g m m -> m +bifoldComplexConstraintFam = $(makeBifold 'ComplexConstraintFam) + instance (Bitraversable (f Int), Traversable g) => Bitraversable (ComplexConstraintFam f g) where bitraverse = $(makeBitraverse 'ComplexConstraintFam) +bisequenceAComplexConstraintFam + :: (Bitraversable (f Int), Traversable g, Applicative t) + => ComplexConstraintFam f g (t a) (t b) -> t (ComplexConstraintFam f g a b) +bisequenceAComplexConstraintFam = $(makeBisequenceA 'ComplexConstraintFam) + $(deriveBifunctor 'UniversalFam) $(deriveBifunctor 'ExistentialListFam) @@ -248,47 +420,54 @@ $(deriveBitraversable 'IntHashFam) $(deriveBifunctor 'IntHashFunFam) -#endif +$(deriveBifunctor 'TyFamily81a) + +$(deriveBifunctor 'TyFamily82) +$(deriveBifoldable 'TyFamily82) +$(deriveBitraversable 'TyFamily82) + ------------------------------------------------------------------------------- -prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d)) - => (a -> c) -> (b -> d) -> p a b -> Bool -prop_BifunctorLaws f g x = - bimap id id x == x - && first id x == x - && second id x == x - && bimap f g x == (first f . second g) x +prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d), Show (p a b), Show (p c d)) + => (a -> c) -> (b -> d) -> p a b -> Expectation +prop_BifunctorLaws f g x = do + bimap id id x `shouldBe` x + first id x `shouldBe` x + second id x `shouldBe` x + bimap f g x `shouldBe` (first f . second g) x -prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int])) => p [Int] [Int] -> Bool +prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42]) -prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Bifoldable p) +prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, + Monoid a, Monoid b, Bifoldable p) => (a -> b) -> (a -> b) -> (a -> z -> z) -> (a -> z -> z) - -> z -> p a a -> Bool -prop_BifoldableLaws f g h i z x = - bifold x == bifoldMap id id x - && bifoldMap f g x == bifoldr (mappend . f) (mappend . g) mempty x - && bifoldr h i z x == appEndo (bifoldMap (Endo . h) (Endo . i) x) z + -> z -> p a a -> Expectation +prop_BifoldableLaws f g h i z x = do + bifold x `shouldBe` bifoldMap id id x + bifoldMap f g x `shouldBe` bifoldr (mappend . f) (mappend . g) mempty x + bifoldr h i z x `shouldBe` appEndo (bifoldMap (Endo . h) (Endo . i) x) z -prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Bool +prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Expectation prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0 -prop_BitraversableLaws :: (Applicative f, Applicative g, - Bitraversable p, Eq (f (p c c)), Eq (g (p c c)), - Eq (p a b), Eq (p d e), Eq1 f) +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 -> Bool -prop_BitraversableLaws f g h i t x = - bitraverse (t . f) (t . g) x == (t . bitraverse f g) x - && bitraverse Identity Identity x == Identity x - && (Compose . fmap (bitraverse h i) . bitraverse f g) x - == bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x + -> (forall x. f x -> g x) -> p a b -> Expectation +prop_BitraversableLaws f g h i t x = do + bitraverse (t . f) (t . g) x `shouldBe` (t . bitraverse f g) x + bitraverse Identity Identity x `shouldBe` Identity x + (Compose . fmap (bitraverse h i) . bitraverse f g) x + `shouldBe` bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x -prop_BitraversableEx :: (Bitraversable p, Eq (p Char Char), - Eq (p [Char] [Char]), Eq (p [Int] [Int])) - => p [Int] [Int] -> Bool +prop_BitraversableEx :: (Bitraversable p, + Eq (p Char Char), Eq (p [Char] [Char]), Eq (p [Int] [Int]), + Show (p Char Char), Show (p [Char] [Char]), Show (p [Int] [Int])) + => p [Int] [Int] -> Expectation prop_BitraversableEx = prop_BitraversableLaws (replicate 2 . map (chr . abs)) (replicate 4 . map (chr . abs)) @@ -305,17 +484,15 @@ spec = do describe "OneTwoCompose Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws" - (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool) + (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bifoldable laws" - (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool) + (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws" - (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool) -#if MIN_VERSION_template_haskell(2,7,0) + (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws" - (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool) + (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bifoldable laws" - (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool) + (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws" - (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool) -#endif + (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) diff --git a/tests/T89Spec.hs b/tests/T89Spec.hs new file mode 100644 --- /dev/null +++ b/tests/T89Spec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A regression test for #89 which ensures that a TH-generated Bifoldable +-- instance of a certain shape does not trigger -Wunused-matches warnings. +module T89Spec where + +import Data.Bifunctor.TH +import Test.Hspec + +data X = MkX +data Y a b = MkY a b +newtype XY a b = XY { getResp :: Either X (Y a b) } + +$(deriveBifoldable ''Y) +$(deriveBifoldable ''XY) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = return ()