bifunctors 5.5.15 → 5.6.3
raw patch · 22 files changed
Files
- CHANGELOG.markdown +89/−1
- bifunctors.cabal +26/−54
- include/bifunctors-common.h +0/−19
- old-src/ghc709/Data/Bifunctor.hs +0/−185
- old-src/ghc801/Data/Bifoldable.hs +0/−487
- old-src/ghc801/Data/Bitraversable.hs +0/−320
- src/Data/Biapplicative.hs +2/−13
- src/Data/Bifunctor/Biap.hs +3/−56
- src/Data/Bifunctor/Biff.hs +16/−73
- src/Data/Bifunctor/Clown.hs +9/−79
- src/Data/Bifunctor/Fix.hs +5/−48
- src/Data/Bifunctor/Flip.hs +19/−46
- src/Data/Bifunctor/Functor.hs +2/−15
- src/Data/Bifunctor/Join.hs +11/−48
- src/Data/Bifunctor/Joker.hs +13/−78
- src/Data/Bifunctor/Product.hs +16/−65
- src/Data/Bifunctor/Sum.hs +11/−68
- src/Data/Bifunctor/TH.hs +6/−42
- src/Data/Bifunctor/TH/Internal.hs +44/−170
- src/Data/Bifunctor/Tannen.hs +15/−68
- src/Data/Bifunctor/Wrapped.hs +9/−72
- tests/BifunctorSpec.hs +6/−50
CHANGELOG.markdown view
@@ -1,3 +1,91 @@+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.*`.@@ -55,7 +143,7 @@ * Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for data types in the `Data.Bifunctor.*` module namespace where possible. The operative phrase is "where possible" since many of these instances require- the use of `Eq2`/`Ord2`/`Read2`/`Show2`, which are not avaiable when+ the use of `Eq2`/`Ord2`/`Read2`/`Show2`, which are not available when built against `transformers-0.4.*`. 5.5.4 [2019.04.26]
bifunctors.cabal view
@@ -1,8 +1,8 @@+cabal-version: 1.24 name: bifunctors category: Data, Functors-version: 5.5.15+version: 5.6.3 license: BSD3-cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -13,39 +13,28 @@ synopsis: Bifunctors description: Bifunctors. build-type: Simple-tested-with: GHC == 7.0.4- , GHC == 7.2.2- , GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+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.6- , GHC == 9.4.4- , GHC == 9.6.1+ , 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- include/bifunctors-common.h source-repository head type: git location: https://github.com/ekmett/bifunctors.git -flag semigroups- default: True- manual: True- description:- You can disable the use of the `semigroups` package using `-f-semigroups`.- .- Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- flag tagged default: True manual: True@@ -56,41 +45,29 @@ library hs-source-dirs: src- include-dirs: include- includes: bifunctors-common.h build-depends:- base >= 4.3 && < 5,- base-orphans >= 0.8.4 && < 1,- comonad >= 5.0.7 && < 6,- containers >= 0.2 && < 0.7,- template-haskell >= 2.4 && < 2.21,- th-abstraction >= 0.4.2.0 && < 0.6,- transformers >= 0.3 && < 0.7-- if !impl(ghc > 8.2)- build-depends: transformers-compat >= 0.5 && < 0.8+ 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 !impl(ghc >= 8.0)- build-depends: fail == 4.9.*+ if !impl(ghc >= 8.2)+ build-depends:+ bifunctor-classes-compat >= 0.1 && < 0.2,+ transformers-compat >= 0.6 && < 0.8 if flag(tagged) build-depends: tagged >= 0.8.6 && < 1 - if flag(semigroups) && !impl(ghc >= 8.0)- build-depends: semigroups >= 0.18.5 && < 1-- if impl(ghc<7.9)- hs-source-dirs: old-src/ghc709- exposed-modules: Data.Bifunctor- if impl(ghc<8.1)- hs-source-dirs: old-src/ghc801- exposed-modules:- Data.Bifoldable- Data.Bitraversable+ 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@@ -110,7 +87,6 @@ other-modules: Data.Bifunctor.TH.Internal- Paths_bifunctors ghc-options: -Wall default-language: Haskell2010@@ -134,8 +110,4 @@ base >= 4 && < 5, bifunctors, hspec >= 1.8,- QuickCheck >= 2 && < 3,- template-haskell,- transformers,- transformers-compat-+ QuickCheck >= 2 && < 3
− include/bifunctors-common.h
@@ -1,19 +0,0 @@-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#ifndef MIN_VERSION_transformers_compat-#define MIN_VERSION_transformers_compat(x,y,z) 0-#endif--#if MIN_VERSION_base(4,9,0)-#define LIFTED_FUNCTOR_CLASSES 1-#else-#if MIN_VERSION_transformers(0,5,0)-#define LIFTED_FUNCTOR_CLASSES 1-#else-#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)-#define LIFTED_FUNCTOR_CLASSES 1-#endif-#endif-#endif
− old-src/ghc709/Data/Bifunctor.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Copyright : (C) 2008-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bifunctor- ( -- * Overview- --- -- Bifunctors extend the standard 'Functor' to two arguments-- -- * Examples- -- $examples- Bifunctor(..)- ) where--import Control.Applicative-import Data.Functor.Constant-import Data.Semigroup--#ifdef MIN_VERSION_tagged-import Data.Tagged-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (K1(..))-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif---- | Minimal definition either 'bimap' or 'first' and 'second'---- | Formally, the class 'Bifunctor' represents a bifunctor--- from @Hask@ -> @Hask@.------ Intuitively it is a bifunctor where both the first and second arguments are covariant.------ You can define a 'Bifunctor' by either defining 'bimap' or by defining both--- 'first' and 'second'.------ If you supply 'bimap', you should ensure that:------ @'bimap' 'id' 'id' ≡ 'id'@------ If you supply 'first' and 'second', ensure:------ @--- 'first' 'id' ≡ 'id'--- 'second' 'id' ≡ 'id'--- @------ If you supply both, you should also ensure:------ @'bimap' f g ≡ 'first' f '.' 'second' g@------ These ensure by parametricity:------ @--- 'bimap' (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i--- 'first' (f '.' g) ≡ 'first' f '.' 'first' g--- 'second' (f '.' g) ≡ 'second' f '.' 'second' g--- @-class Bifunctor p where- -- | Map over both arguments at the same time.- --- -- @'bimap' f g ≡ 'first' f '.' 'second' g@- bimap :: (a -> b) -> (c -> d) -> p a c -> p b d- bimap f g = first f . second g- {-# INLINE bimap #-}-- -- | Map covariantly over the first argument.- --- -- @'first' f ≡ 'bimap' f 'id'@- first :: (a -> b) -> p a c -> p b c- first f = bimap f id- {-# INLINE first #-}-- -- | Map covariantly over the second argument.- --- -- @'second' ≡ 'bimap' 'id'@- second :: (b -> c) -> p a b -> p a c- second = bimap id- {-# INLINE second #-}--#if __GLASGOW_HASKELL__ >= 708- {-# MINIMAL bimap | first, second #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-deriving instance Typeable Bifunctor-#endif--instance Bifunctor (,) where- bimap f g ~(a, b) = (f a, g b)- {-# INLINE bimap #-}--instance Bifunctor Arg where- bimap f g (Arg a b) = Arg (f a) (g b)--instance Bifunctor ((,,) x) where- bimap f g ~(x, a, b) = (x, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,) x y) where- bimap f g ~(x, y, a, b) = (x, y, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,,) x y z) where- bimap f g ~(x, y, z, a, b) = (x, y, z, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,,,) x y z w) where- bimap f g ~(x, y, z, w, a, b) = (x, y, z, w, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor ((,,,,,,) x y z w v) where- bimap f g ~(x, y, z, w, v, a, b) = (x, y, z, w, v, f a, g b)- {-# INLINE bimap #-}--instance Bifunctor Either where- bimap f _ (Left a) = Left (f a)- bimap _ g (Right b) = Right (g b)- {-# INLINE bimap #-}--instance Bifunctor Const where- bimap f _ (Const a) = Const (f a)- {-# INLINE bimap #-}--instance Bifunctor Constant where- bimap f _ (Constant a) = Constant (f a)- {-# INLINE bimap #-}--#if __GLASGOW_HASKELL__ >= 702-instance Bifunctor (K1 i) where- bimap f _ (K1 c) = K1 (f c)- {-# INLINE bimap #-}-#endif--#ifdef MIN_VERSION_tagged-instance Bifunctor Tagged where- bimap _ g (Tagged b) = Tagged (g b)- {-# INLINE bimap #-}-#endif---- $examples------ ==== __Examples__------ While the standard 'Functor' instance for 'Either' is limited to mapping over 'Right' arguments,--- the 'Bifunctor' instance allows mapping over the 'Left', 'Right', or both arguments:------ > let x = Left "foo" :: Either String Integer------ In the case of 'first' and 'second', the function may or may not be applied:------ > first (++ "bar") x == Left "foobar"--- > second (+2) x == Left "foo"------ In the case of 'bimap', only one of the functions will be applied:------ > bimap (++ "bar") (+2) x == Left "foobar"------ The 'Bifunctor' instance for 2 element tuples allows mapping over one or both of the elements:------ > let x = ("foo",1)--- >--- > first (++ "bar") x == ("foobar", 1)--- > second (+2) x == ("foo", 3)--- > bimap (++ "bar") (+2) x == ("foobar", 3)
− old-src/ghc801/Data/Bifoldable.hs
@@ -1,487 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bifoldable- ( Bifoldable(..)- , bifoldr'- , bifoldr1- , bifoldrM- , bifoldl'- , bifoldl1- , bifoldlM- , bitraverse_- , bifor_- , bimapM_- , biforM_- , bimsum- , bisequenceA_- , bisequence_- , biasum- , biList- , binull- , bilength- , bielem- , bimaximum- , biminimum- , bisum- , biproduct- , biconcat- , biconcatMap- , biand- , bior- , biany- , biall- , bimaximumBy- , biminimumBy- , binotElem- , bifind- ) where--import Control.Applicative-import Control.Monad-import Data.Functor.Constant-import Data.Maybe (fromMaybe)-import Data.Monoid--#if MIN_VERSION_base(4,7,0)-import Data.Coerce-#else-import Unsafe.Coerce-#endif--import Data.Semigroup (Arg(..))--#ifdef MIN_VERSION_tagged-import Data.Tagged-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (K1(..))-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-import Data.Typeable-#endif---- | 'Bifoldable' identifies foldable structures with two different varieties--- of elements (as opposed to 'Foldable', which has one variety of element).--- Common examples are 'Either' and '(,)':------ > instance Bifoldable Either where--- > bifoldMap f _ (Left a) = f a--- > bifoldMap _ g (Right b) = g b--- >--- > instance Bifoldable (,) where--- > bifoldr f g z (a, b) = f a (g b z)------ A minimal 'Bifoldable' definition consists of either 'bifoldMap' or--- 'bifoldr'. When defining more than this minimal set, one should ensure--- that the following identities hold:------ @--- 'bifold' ≡ 'bifoldMap' 'id' 'id'--- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'--- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z--- @------ If the type is also a 'Bifunctor' instance, it should satisfy:------ > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g------ which implies that------ > 'bifoldMap' f g . 'bimap' h i ≡ 'bifoldMap' (f . h) (g . i)-class Bifoldable p where- -- | Combines the elements of a structure using a monoid.- --- -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@- bifold :: Monoid m => p m m -> m- bifold = bifoldMap id id- {-# INLINE bifold #-}-- -- | Combines the elements of a structure, given ways of mapping them to a- -- common monoid.- --- -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@- bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m- bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty- {-# INLINE bifoldMap #-}-- -- | Combines the elements of a structure in a right associative manner. Given- -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a- -- list of all elements of a structure in order, the following would hold:- --- -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@- bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c- bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z- {-# INLINE bifoldr #-}-- -- | Combines the elments of a structure in a left associative manner. Given a- -- hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a- -- list of all elements of a structure in order, the following would hold:- --- -- @'bifoldl' f g z ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@- --- -- Note that if you want an efficient left-fold, you probably want to use- -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not- -- force the "inner" results, resulting in a thunk chain which then must be- -- evaluated from the outside-in.- bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c- bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z- {-# INLINE bifoldl #-}--#if __GLASGOW_HASKELL__ >= 708- {-# MINIMAL bifoldr | bifoldMap #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-deriving instance Typeable Bifoldable-#endif--instance Bifoldable Arg where- bifoldMap f g (Arg a b) = f a `mappend` g b--instance Bifoldable (,) where- bifoldMap f g ~(a, b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable Const where- bifoldMap f _ (Const a) = f a- {-# INLINE bifoldMap #-}--instance Bifoldable Constant where- bifoldMap f _ (Constant a) = f a- {-# INLINE bifoldMap #-}--#if __GLASGOW_HASKELL__ >= 702-instance Bifoldable (K1 i) where- bifoldMap f _ (K1 c) = f c- {-# INLINE bifoldMap #-}-#endif--instance Bifoldable ((,,) x) where- bifoldMap f g ~(_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,) x y) where- bifoldMap f g ~(_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,,) x y z) where- bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,,,) x y z w) where- bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--instance Bifoldable ((,,,,,,) x y z w v) where- bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b- {-# INLINE bifoldMap #-}--#ifdef MIN_VERSION_tagged-instance Bifoldable Tagged where- bifoldMap _ g (Tagged b) = g b- {-# INLINE bifoldMap #-}-#endif--instance Bifoldable Either where- bifoldMap f _ (Left a) = f a- bifoldMap _ g (Right b) = g b- {-# INLINE bifoldMap #-}---- | As 'bifoldr', but strict in the result of the reduction functions at each--- step.-bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c-bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where- f' k x z = k $! f x z- g' k x z = k $! g x z-{-# INLINE bifoldr' #-}---- | A variant of 'bifoldr' that has no base case,--- and thus may only be applied to non-empty structures.-bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a-bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure")- (bifoldr mbf mbf Nothing xs)- where- mbf x m = Just (case m of- Nothing -> x- Just y -> f x y)-{-# INLINE bifoldr1 #-}---- | Right associative monadic bifold over a structure.-bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c-bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where- f' k x z = f x z >>= k- g' k x z = g x z >>= k-{-# INLINE bifoldrM #-}---- | As 'bifoldl', but strict in the result of the reduction functions at each--- step.------ This ensures that each step of the bifold is forced to weak head normal form--- before being applied, avoiding the collection of thunks that would otherwise--- occur. This is often what you want to strictly reduce a finite structure to--- a single, monolithic result (e.g., 'bilength').-bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a-bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where- f' x k z = k $! f z x- g' x k z = k $! g z x-{-# INLINE bifoldl' #-}---- | A variant of 'bifoldl' that has no base case,--- and thus may only be applied to non-empty structures.-bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a-bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure")- (bifoldl mbf mbf Nothing xs)- where- mbf m y = Just (case m of- Nothing -> y- Just x -> f x y)-{-# INLINe bifoldl1 #-}---- | Left associative monadic bifold over a structure.-bifoldlM :: (Bifoldable t, Monad m) => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a-bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where- f' x k z = f z x >>= k- g' x k z = g z x >>= k-{-# INLINE bifoldlM #-}---- | Map each element of a structure using one of two actions, evaluate these--- actions from left to right, and ignore the results. For a version that--- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'.-bitraverse_ :: (Bifoldable t, Applicative f) => (a -> f c) -> (b -> f d) -> t a b -> f ()-bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())-{-# INLINE bitraverse_ #-}---- | As 'bitraverse_', but with the structure as the primary argument. For a--- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'.------ >>> > bifor_ ('a', "bc") print (print . reverse)--- 'a'--- "cb"-bifor_ :: (Bifoldable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f ()-bifor_ t f g = bitraverse_ f g t-{-# INLINE bifor_ #-}---- | As 'Data.Bitraversable.bimapM', but ignores the results of the functions,--- merely performing the "actions".-bimapM_:: (Bifoldable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m ()-bimapM_ f g = bifoldr ((>>) . f) ((>>) . g) (return ())-{-# INLINE bimapM_ #-}---- | As 'bimapM_', but with the structure as the primary argument.-biforM_ :: (Bifoldable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m ()-biforM_ t f g = bimapM_ f g t-{-# INLINE biforM_ #-}---- | As 'Data.Bitraversable.bisequenceA', but ignores the results of the actions.-bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()-bisequenceA_ = bifoldr (*>) (*>) (pure ())-{-# INLINE bisequenceA_ #-}---- | Evaluate each action in the structure from left to right, and ignore the--- results. For a version that doesn't ignore the results, see--- 'Data.Bitraversable.bisequence'.-bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m ()-bisequence_ = bifoldr (>>) (>>) (return ())-{-# INLINE bisequence_ #-}---- | The sum of a collection of actions, generalizing 'biconcat'.-biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a-biasum = bifoldr (<|>) (<|>) empty-{-# INLINE biasum #-}---- | The sum of a collection of actions, generalizing 'biconcat'.-bimsum :: (Bifoldable t, MonadPlus m) => t (m a) (m a) -> m a-bimsum = bifoldr mplus mplus mzero-{-# INLINE bimsum #-}---- | Collects the list of elements of a structure, from left to right.-biList :: Bifoldable t => t a a -> [a]-biList = bifoldr (:) (:) []-{-# INLINE biList #-}---- | Test whether the structure is empty.-binull :: Bifoldable t => t a b -> Bool-binull = bifoldr (\_ _ -> False) (\_ _ -> False) True-{-# INLINE binull #-}---- | Returns the size/length of a finite structure as an 'Int'.-bilength :: Bifoldable t => t a b -> Int-bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0-{-# INLINE bilength #-}---- | Does the element occur in the structure?-bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool-bielem x = biany (== x) (== x)-{-# INLINE bielem #-}---- | Reduces a structure of lists to the concatenation of those lists.-biconcat :: Bifoldable t => t [a] [a] -> [a]-biconcat = bifold-{-# INLINE biconcat #-}--newtype Max a = Max {getMax :: Maybe a}-newtype Min a = Min {getMin :: Maybe a}--instance Ord a => Monoid (Max a) where- mempty = Max Nothing-- {-# INLINE mappend #-}- m `mappend` Max Nothing = m- Max Nothing `mappend` n = n- (Max m@(Just x)) `mappend` (Max n@(Just y))- | x >= y = Max m- | otherwise = Max n--instance Ord a => Monoid (Min a) where- mempty = Min Nothing-- {-# INLINE mappend #-}- m `mappend` Min Nothing = m- Min Nothing `mappend` n = n- (Min m@(Just x)) `mappend` (Min n@(Just y))- | x <= y = Min m- | otherwise = Min n---- | The largest element of a non-empty structure.-bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a-bimaximum = fromMaybe (error "bimaximum: empty structure") .- getMax . bifoldMap mj mj- where mj = Max #. (Just :: a -> Maybe a)-{-# INLINE bimaximum #-}---- | The least element of a non-empty structure.-biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a-biminimum = fromMaybe (error "biminimum: empty structure") .- getMin . bifoldMap mj mj- where mj = Min #. (Just :: a -> Maybe a)-{-# INLINE biminimum #-}---- | The 'bisum' function computes the sum of the numbers of a structure.-bisum :: (Bifoldable t, Num a) => t a a -> a-bisum = getSum #. bifoldMap Sum Sum-{-# INLINE bisum #-}---- | The 'biproduct' function computes the product of the numbers of a--- structure.-biproduct :: (Bifoldable t, Num a) => t a a -> a-biproduct = getProduct #. bifoldMap Product Product-{-# INLINE biproduct #-}---- | Given a means of mapping the elements of a structure to lists, computes the--- concatenation of all such lists in order.-biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c]-biconcatMap = bifoldMap-{-# INLINE biconcatMap #-}---- | 'biand' returns the conjunction of a container of Bools. For the--- result to be 'True', the container must be finite; 'False', however,--- results from a 'False' value finitely far from the left end.-biand :: Bifoldable t => t Bool Bool -> Bool-biand = getAll #. bifoldMap All All-{-# INLINE biand #-}---- | 'bior' returns the disjunction of a container of Bools. For the--- result to be 'False', the container must be finite; 'True', however,--- results from a 'True' value finitely far from the left end.-bior :: Bifoldable t => t Bool Bool -> Bool-bior = getAny #. bifoldMap Any Any-{-# INLINE bior #-}---- | Determines whether any element of the structure satisfies the appropriate--- predicate.-biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool-biany p q = getAny #. bifoldMap (Any . p) (Any . q)-{-# INLINE biany #-}---- | Determines whether all elements of the structure satisfy the appropriate--- predicate.-biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool-biall p q = getAll #. bifoldMap (All . p) (All . q)-{-# INLINE biall #-}---- | The largest element of a non-empty structure with respect to the--- given comparison function.-bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a-bimaximumBy cmp = bifoldr1 max'- where max' x y = case cmp x y of- GT -> x- _ -> y-{-# INLINE bimaximumBy #-}---- | The least element of a non-empty structure with respect to the--- given comparison function.-biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a-biminimumBy cmp = bifoldr1 min'- where min' x y = case cmp x y of- GT -> y- _ -> x-{-# INLINE biminimumBy #-}---- | 'binotElem' is the negation of 'bielem'.-binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool-binotElem x = not . bielem x-{-# INLINE binotElem #-}---- | The 'bifind' function takes a predicate and a structure and returns--- the leftmost element of the structure matching the predicate, or--- 'Nothing' if there is no such element.-bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a-bifind p = getFirst . bifoldMap finder finder- where finder x = First (if p x then Just x else Nothing)-{-# INLINE bifind #-}---- See Note [Function coercion]-#if MIN_VERSION_base(4,7,0)-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = coerce-#else-(#.) :: (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = unsafeCoerce-#endif-{-# INLINE (#.) #-}--{--Note [Function coercion]-~~~~~~~~~~~~~~~~~~~~~~~~--Several functions here use (#.) instead of (.) to avoid potential efficiency-problems relating to #7542. The problem, in a nutshell:--If N is a newtype constructor, then N x will always have the same-representation as x (something similar applies for a newtype deconstructor).-However, if f is a function,--N . f = \x -> N (f x)--This looks almost the same as f, but the eta expansion lifts it--the lhs could-be _|_, but the rhs never is. This can lead to very inefficient code. Thus we-steal a technique from Shachaf and Edward Kmett and adapt it to the current-(rather clean) setting. Instead of using N . f, we use N .## f, which is-just--coerce f `asTypeOf` (N . f)--That is, we just *pretend* that f has the right type, and thanks to the safety-of coerce, the type checker guarantees that nothing really goes wrong. We still-have to be a bit careful, though: remember that #. completely ignores the-*value* of its left operand.--}
− old-src/ghc801/Data/Bitraversable.hs
@@ -1,320 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Data.Bitraversable- ( Bitraversable(..)- , bisequenceA- , bisequence- , bimapM- , bifor- , biforM- , bimapAccumL- , bimapAccumR- , bimapDefault- , bifoldMapDefault- ) where--import Control.Applicative-import Control.Monad.Trans.Instances ()-import Data.Bifunctor-import Data.Bifoldable-import Data.Functor.Constant-import Data.Functor.Identity-import Data.Orphans ()--#if MIN_VERSION_base(4,7,0)-import Data.Coerce (coerce)-#else-import Unsafe.Coerce (unsafeCoerce)-#endif--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif--import Data.Semigroup (Arg(..))--#ifdef MIN_VERSION_tagged-import Data.Tagged-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (K1(..))-#endif--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-import Data.Typeable-#endif---- | 'Bitraversable' identifies bifunctorial data structures whose elements can--- be traversed in order, performing 'Applicative' or 'Monad' actions at each--- element, and collecting a result structure with the same shape.------ As opposed to 'Traversable' data structures, which have one variety of--- element on which an action can be performed, 'Bitraversable' data structures--- have two such varieties of elements.------ A definition of 'bitraverse' must satisfy the following laws:------ [/naturality/]--- @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@--- for every applicative transformation @t@------ [/identity/]--- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@------ [/composition/]--- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2--- ≡ 'bitraverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@------ where an /applicative transformation/ is a function------ @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@------ preserving the 'Applicative' operations:------ @--- t ('pure' x) = 'pure' x--- t (f '<*>' x) = t f '<*>' t x--- @------ and the identity functor 'Identity' and composition functors 'Compose' are--- defined as------ > newtype Identity a = Identity { runIdentity :: a }--- >--- > instance Functor Identity where--- > fmap f (Identity x) = Identity (f x)--- >--- > instance Applicative Identity where--- > pure = Identity--- > Identity f <*> Identity x = Identity (f x)--- >--- > newtype Compose f g a = Compose (f (g a))--- >--- > instance (Functor f, Functor g) => Functor (Compose f g) where--- > fmap f (Compose x) = Compose (fmap (fmap f) x)--- >--- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where--- > pure = Compose . pure . pure--- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)------ Some simple examples are 'Either' and '(,)':------ > instance Bitraversable Either where--- > bitraverse f _ (Left x) = Left <$> f x--- > bitraverse _ g (Right y) = Right <$> g y--- >--- > instance Bitraversable (,) where--- > bitraverse f g (x, y) = (,) <$> f x <*> g y------ 'Bitraversable' relates to its superclasses in the following ways:------ @--- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)--- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)--- @------ These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.-class (Bifunctor t, Bifoldable t) => Bitraversable t where- -- | Evaluates the relevant functions at each element in the structure, running- -- the action, and builds a new structure with the same shape, using the- -- elements produced from sequencing the actions.- --- -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@- --- -- For a version that ignores the results, see 'bitraverse_'.- bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)----- | Sequences all the actions in a structure, building a new structure with the--- same shape using the results of the actions. For a version that ignores the--- results, see 'bisequenceA_'.------ @'bisequenceA' ≡ 'bitraverse' 'id' 'id'@-bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)-bisequenceA = bitraverse id id-{-# INLINE bisequenceA #-}---- | As 'bitraverse', but uses evidence that @m@ is a 'Monad' rather than an--- 'Applicative'. For a version that ignores the results, see 'bimapM_'.------ @--- 'bimapM' f g ≡ 'bisequence' . 'bimap' f g--- 'bimapM' f g ≡ 'unwrapMonad' . 'bitraverse' ('WrapMonad' . f) ('WrapMonad' . g)--- @-bimapM :: (Bitraversable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m (t c d)-bimapM f g = unwrapMonad . bitraverse (WrapMonad . f) (WrapMonad . g)-{-# INLINE bimapM #-}---- | As 'bisequenceA', but uses evidence that @m@ is a 'Monad' rather than an--- 'Applicative'. For a version that ignores the results, see 'bisequence_'.------ @--- 'bisequence' ≡ 'bimapM' 'id' 'id'--- 'bisequence' ≡ 'unwrapMonad' . 'bisequenceA' . 'bimap' 'WrapMonad' 'WrapMonad'--- @-bisequence :: (Bitraversable t, Monad m) => t (m a) (m b) -> m (t a b)-bisequence = bimapM id id-{-# INLINE bisequence #-}--#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-deriving instance Typeable Bitraversable-#endif--instance Bitraversable Arg where- bitraverse f g (Arg a b) = Arg <$> f a <*> g b--instance Bitraversable (,) where- bitraverse f g ~(a, b) = (,) <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,) x) where- bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,) x y) where- bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,,) x y z) where- bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,,,) x y z w) where- bitraverse f g ~(x, y, z, w, a, b) = (,,,,,) x y z w <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable ((,,,,,,) x y z w v) where- bitraverse f g ~(x, y, z, w, v, a, b) = (,,,,,,) x y z w v <$> f a <*> g b- {-# INLINE bitraverse #-}--instance Bitraversable Either where- bitraverse f _ (Left a) = Left <$> f a- bitraverse _ g (Right b) = Right <$> g b- {-# INLINE bitraverse #-}--instance Bitraversable Const where- bitraverse f _ (Const a) = Const <$> f a- {-# INLINE bitraverse #-}--instance Bitraversable Constant where- bitraverse f _ (Constant a) = Constant <$> f a- {-# INLINE bitraverse #-}--#if __GLASGOW_HASKELL__ >= 702-instance Bitraversable (K1 i) where- bitraverse f _ (K1 c) = K1 <$> f c- {-# INLINE bitraverse #-}-#endif--#ifdef MIN_VERSION_tagged-instance Bitraversable Tagged where- bitraverse _ g (Tagged b) = Tagged <$> g b- {-# INLINE bitraverse #-}-#endif---- | 'bifor' is 'bitraverse' with the structure as the first argument. For a--- version that ignores the results, see 'bifor_'.-bifor :: (Bitraversable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)-bifor t f g = bitraverse f g t-{-# INLINE bifor #-}---- | 'biforM' is 'bimapM' with the structure as the first argument. For a--- version that ignores the results, see 'biforM_'.-biforM :: (Bitraversable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m (t c d)-biforM t f g = bimapM f g t-{-# INLINE biforM #-}---- | left-to-right state transformer-newtype StateL s a = StateL { runStateL :: s -> (s, a) }--instance Functor (StateL s) where- fmap f (StateL k) = StateL $ \ s ->- let (s', v) = k s in (s', f v)- {-# INLINE fmap #-}--instance Applicative (StateL s) where- pure x = StateL (\ s -> (s, x))- {-# INLINE pure #-}- StateL kf <*> StateL kv = StateL $ \ s ->- let (s', f) = kf s- (s'', v) = kv s'- in (s'', f v)- {-# INLINE (<*>) #-}---- | The 'bimapAccumL' function behaves like a combination of 'bimap' and--- 'bifoldl'; it traverses a structure from left to right, threading a state--- of type @a@ and using the given actions to compute new elements for the--- structure.-bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)-bimapAccumL f g s t = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s-{-# INLINE bimapAccumL #-}---- | right-to-left state transformer-newtype StateR s a = StateR { runStateR :: s -> (s, a) }--instance Functor (StateR s) where- fmap f (StateR k) = StateR $ \ s ->- let (s', v) = k s in (s', f v)- {-# INLINE fmap #-}--instance Applicative (StateR s) where- pure x = StateR (\ s -> (s, x))- {-# INLINE pure #-}- StateR kf <*> StateR kv = StateR $ \ s ->- let (s', v) = kv s- (s'', f) = kf s'- in (s'', f v)- {-# INLINE (<*>) #-}---- | The 'bimapAccumR' function behaves like a combination of 'bimap' and--- 'bifoldl'; it traverses a structure from right to left, threading a state--- of type @a@ and using the given actions to compute new elements for the--- structure.-bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)-bimapAccumR f g s t = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s-{-# INLINE bimapAccumR #-}---- | A default definition of 'bimap' in terms of the 'Bitraversable' operations.------ @'bimapDefault' f g ≡--- 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@-bimapDefault :: forall t a b c d . Bitraversable t- => (a -> b) -> (c -> d) -> t a c -> t b d-bimapDefault = coerce- (bitraverse :: (a -> Identity b)- -> (c -> Identity d) -> t a c -> Identity (t b d))-{-# INLINE bimapDefault #-}---- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' operations.------ @'bifoldMapDefault' f g ≡--- 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@-bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)- => (a -> m) -> (b -> m) -> t a b -> m-bifoldMapDefault = coerce- (bitraverse :: (a -> Const m ())- -> (b -> Const m ()) -> t a b -> Const m (t () ()))-{-# INLINE bifoldMapDefault #-}--#if !(MIN_VERSION_base(4,7,0))-coerce :: a -> b-coerce = unsafeCoerce-#endif
src/Data/Biapplicative.hs view
@@ -2,10 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |@@ -32,14 +29,8 @@ import Control.Applicative import Data.Bifunctor import Data.Functor.Identity-import GHC.Exts (inline)--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-import Data.Traversable (Traversable (traverse))-#endif- import Data.Semigroup (Arg(..))+import GHC.Exts (inline) #ifdef MIN_VERSION_tagged import Data.Tagged@@ -51,9 +42,7 @@ {-# INLINE (<<$>>) #-} class Bifunctor p => Biapplicative p where-#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-}-#endif bipure :: a -> b -> p a b (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d@@ -139,7 +128,7 @@ -- versions for a few important types. {-# INLINABLE [1] traverseBia #-} --- | Perform all the 'Biappicative' actions in a 'Traversable' container+-- | Perform all the 'Biapplicative' actions in a 'Traversable' container -- and produce a container with all the results. -- -- @
src/Data/Bifunctor/Biap.hs view
@@ -1,20 +1,13 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif- -- This module uses GND-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h" ----------------------------------------------------------------------------- -- |@@ -37,18 +30,8 @@ import Data.Bifoldable import Data.Bitraversable import Data.Functor.Classes--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics-#endif--#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif- import qualified Data.Semigroup as S+import GHC.Generics -- | Pointwise lifting of a class over two arguments, using -- 'Biapplicative'.@@ -92,25 +75,18 @@ , Traversable , Alternative , Applicative-#if __GLASGOW_HASKELL__ >= 702 , Generic-#endif-#if __GLASGOW_HASKELL__ >= 706 , Generic1-#endif , Monad , Fail.MonadFail , MonadPlus , Eq1 , Ord1- , Bifunctor , Biapplicative , Bifoldable-#if LIFTED_FUNCTOR_CLASSES , Eq2 , Ord2-#endif ) instance Bitraversable bi => Bitraversable (Biap bi) where@@ -129,12 +105,7 @@ minBound = bipure minBound minBound maxBound = bipure maxBound maxBound -instance ( Biapplicative bi, Num a, Num b-#if !(MIN_VERSION_base(4,5,0))- -- Old versions of Num have Eq and Show as superclasses. Sigh.- , Eq (bi a b), Show (bi a b)-#endif- ) => Num (Biap bi a b) where+instance (Biapplicative bi, Num a, Num b) => Num (Biap bi a b) where (+) = biliftA2 (+) (+) (*) = biliftA2 (*) (*) @@ -143,27 +114,3 @@ signum = bimap signum signum fromInteger n = bipure (fromInteger n) (fromInteger n)--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706-data BiapMetaData-data BiapMetaCons-data BiapMetaSel--instance Datatype BiapMetaData where- datatypeName = const "Biap"- moduleName = const "Data.Bifunctor.Wrapped"--instance Constructor BiapMetaCons where- conName = const "Biap"- conIsRecord = const True--instance Selector BiapMetaSel where- selName = const "getBiap"--instance Generic1 (Biap p a) where- type Rep1 (Biap p a) = D1 BiapMetaData- (C1 BiapMetaCons- (S1 BiapMetaSel (Rec1 (p a))))- from1 = M1 . M1 . M1 . Rec1 . getBiap- to1 = Biap . unRec1 . unM1 . unM1 . unM1-#endif
src/Data/Bifunctor/Biff.hs view
@@ -1,26 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"- ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett@@ -35,70 +21,20 @@ ( 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 GHC.Generics-#endif--#if LIFTED_FUNCTOR_CLASSES+import Data.Foldable1 (Foldable1(..)) import Data.Functor.Classes-#endif+import GHC.Generics -- | 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 Constructor BiffMetaCons where- conName = const "Biff"- conIsRecord = const True--instance Selector BiffMetaSel where- selName = const "runBiff"--instance Functor (p (f a)) => Generic1 (Biff p f g a) where- type Rep1 (Biff p f g a) = D1 BiffMetaData (C1 BiffMetaCons- (S1 BiffMetaSel (p (f a) :.: Rec1 g)))- from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runBiff- to1 = Biff . fmap unRec1 . unComp1 . unM1 . unM1 . unM1-# endif-#endif--#if LIFTED_FUNCTOR_CLASSES instance (Eq2 p, Eq1 f, Eq1 g, Eq a) => Eq1 (Biff p f g a) where liftEq = liftEq2 (==) instance (Eq2 p, Eq1 f, Eq1 g) => Eq2 (Biff p f g) where@@ -129,7 +65,6 @@ . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) (liftShowsPrec sp2 sl2) (liftShowList sp2 sl2) 0 x . showChar '}'-#endif instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where first f = Biff . first (fmap f) . runBiff@@ -158,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 #-}@@ -165,3 +104,7 @@ instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (Biff p f g) where bitraverse f g = fmap Biff . bitraverse (traverse f) (traverse g) . runBiff {-# INLINE bitraverse #-}++-- | @since 5.6.1+instance (f ~ g, Functor f, Swap p) => Swap (Biff p f g) where+ swap = Biff . swap . runBiff
src/Data/Bifunctor/Clown.hs view
@@ -1,22 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -34,68 +20,21 @@ ( Clown(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable+import Data.Foldable1 (Foldable1(..)) import Data.Functor.Classes--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Monoid-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702 import GHC.Generics-#endif -- | Make a 'Functor' over the first argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Clown f a b = Clown { runClown :: f a }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data ClownMetaData-data ClownMetaCons-data ClownMetaSel--instance Datatype ClownMetaData where- datatypeName _ = "Clown"- moduleName _ = "Data.Bifunctor.Clown"--instance Constructor ClownMetaCons where- conName _ = "Clown"- conIsRecord _ = True--instance Selector ClownMetaSel where- selName _ = "runClown"--instance Generic1 (Clown f a) where- type Rep1 (Clown f a) = D1 ClownMetaData (C1 ClownMetaCons- (S1 ClownMetaSel (Rec0 (f a))))- from1 = M1 . M1 . M1 . K1 . runClown- to1 = Clown . unK1 . unM1 . unM1 . unM1-#endif+ deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq a) => Eq1 (Clown f a) where liftEq = liftEq2 (==) instance Eq1 f => Eq2 (Clown f) where@@ -115,20 +54,7 @@ liftShowsPrec = liftShowsPrec2 showsPrec showList instance Show1 f => Show2 (Clown f) where liftShowsPrec2 sp1 sl1 _ _ = showsPrecClown (liftShowsPrec sp1 sl1)-#else-instance (Eq1 f, Eq a) => Eq1 (Clown f a) where- eq1 = eqClown eq1 -instance (Ord1 f, Ord a) => Ord1 (Clown f a) where- compare1 = compareClown compare1--instance (Read1 f, Read a) => Read1 (Clown f a) where- readsPrec1 = readsPrecClown readsPrec1--instance (Show1 f, Show a) => Show1 (Clown f a) where- showsPrec1 = showsPrecClown showsPrec1-#endif- eqClown :: (f a1 -> f a2 -> Bool) -> Clown f a1 b1 -> Clown f a2 b2 -> Bool eqClown eqA (Clown x) (Clown y) = eqA x y@@ -178,6 +104,10 @@ instance Foldable f => Bifoldable (Clown f) where bifoldMap f _ = foldMap f . runClown {-# INLINE bifoldMap #-}++instance Foldable1 f => Bifoldable1 (Clown f) where+ bifoldMap1 f _ = foldMap1 f . runClown+ {-# INLINE bifoldMap1 #-} instance Foldable (Clown f a) where foldMap _ = mempty
src/Data/Bifunctor/Fix.hs view
@@ -1,24 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif-#include "bifunctors-common.h"- ----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Fix@@ -34,49 +20,21 @@ ( Fix(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics-#endif--#if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes-#endif+import GHC.Generics -- | 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) -#if LIFTED_FUNCTOR_CLASSES instance Eq2 p => Eq1 (Fix p) where liftEq f (In x) (In y) = liftEq2 (liftEq f) f x y @@ -99,7 +57,6 @@ . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) sp1 sl1 0 x . showChar '}'-#endif instance Bifunctor p => Functor (Fix p) where fmap f (In p) = In (bimap (fmap f) f p)
src/Data/Bifunctor/Flip.hs view
@@ -1,20 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif-#include "bifunctors-common.h"+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- |@@ -31,45 +17,20 @@ ( 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 GHC.Generics-#endif--#if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes-#endif+import GHC.Generics -- | 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) -#if LIFTED_FUNCTOR_CLASSES instance (Eq2 p, Eq a) => Eq1 (Flip p a) where liftEq = liftEq2 (==) instance Eq2 p => Eq2 (Flip p) where@@ -98,7 +59,6 @@ showString "Flip {runFlip = " . liftShowsPrec2 sp2 sl2 sp1 sl1 0 x . showChar '}'-#endif instance Bifunctor p => Bifunctor (Flip p) where first f = Flip . second f . runFlip@@ -123,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 #-}@@ -137,3 +101,12 @@ instance BifunctorFunctor Flip where bifmap f (Flip p) = Flip (f p)++-- | @since 5.6.1+instance Assoc p => Assoc (Flip p) where+ assoc = Flip . first Flip . unassoc . second runFlip . runFlip+ unassoc = Flip . second Flip . assoc . first runFlip . runFlip++-- | @since 5.6.1+instance Swap p => Swap (Flip p) where+ swap = Flip . swap . runFlip
src/Data/Bifunctor/Functor.hs view
@@ -1,16 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}--#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif+{-# LANGUAGE TypeOperators #-} module Data.Bifunctor.Functor ( (:->)@@ -34,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)@@ -48,9 +37,7 @@ biextend f = bifmap f . biduplicate biduplicate :: t p :-> t (t p) biduplicate = biextend id-#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL biextract, (biextend | biduplicate) #-}-#endif biliftW :: BifunctorComonad t => (p :-> q) -> t p :-> t q biliftW f = biextend (f . biextract)
src/Data/Bifunctor/Join.hs view
@@ -1,24 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif-#include "bifunctors-common.h"- ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett@@ -33,49 +19,23 @@ ( 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 GHC.Generics-#endif--#if LIFTED_FUNCTOR_CLASSES+import Data.Foldable1 (Foldable1(..)) import Data.Functor.Classes-#endif+import GHC.Generics -- | 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) -#if LIFTED_FUNCTOR_CLASSES instance Eq2 p => Eq1 (Join p) where liftEq f (Join x) (Join y) = liftEq2 f f x y @@ -96,7 +56,6 @@ showString "Join {runJoin = " . liftShowsPrec2 sp1 sl1 sp1 sl1 0 x . showChar '}'-#endif instance Bifunctor p => Functor (Join p) where fmap f (Join a) = Join (bimap f f a)@@ -115,6 +74,10 @@ instance Bifoldable p => Foldable (Join p) where foldMap f (Join a) = bifoldMap f f a {-# INLINE foldMap #-}++instance Bifoldable1 p => Foldable1 (Join p) where+ foldMap1 f (Join a) = bifoldMap1 f f a+ {-# INLINE foldMap1 #-} instance Bitraversable p => Traversable (Join p) where traverse f (Join a) = fmap Join (bitraverse f f a)
src/Data/Bifunctor/Joker.hs view
@@ -1,22 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -34,67 +20,21 @@ ( Joker(..) ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Data.Biapplicative import Data.Bifoldable+import Data.Bifoldable1 (Bifoldable1(..)) import Data.Bitraversable+import Data.Foldable1 (Foldable1(..)) import Data.Functor.Classes--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702 import GHC.Generics-#endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Joker g a b = Joker { runJoker :: g b }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data JokerMetaData-data JokerMetaCons-data JokerMetaSel--instance Datatype JokerMetaData where- datatypeName _ = "Joker"- moduleName _ = "Data.Bifunctor.Joker"--instance Constructor JokerMetaCons where- conName _ = "Joker"- conIsRecord _ = True--instance Selector JokerMetaSel where- selName _ = "runJoker"--instance Generic1 (Joker g a) where- type Rep1 (Joker g a) = D1 JokerMetaData (C1 JokerMetaCons- (S1 JokerMetaSel (Rec1 g)))- from1 = M1 . M1 . M1 . Rec1 . runJoker- to1 = Joker . unRec1 . unM1 . unM1 . unM1-#endif+ deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if LIFTED_FUNCTOR_CLASSES instance Eq1 g => Eq1 (Joker g a) where liftEq g = eqJoker (liftEq g) instance Eq1 g => Eq2 (Joker g) where@@ -114,20 +54,7 @@ liftShowsPrec sp sl = showsPrecJoker (liftShowsPrec sp sl) instance Show1 g => Show2 (Joker g) where liftShowsPrec2 _ _ sp2 sl2 = showsPrecJoker (liftShowsPrec sp2 sl2)-#else-instance Eq1 g => Eq1 (Joker g a) where- eq1 = eqJoker eq1 -instance Ord1 g => Ord1 (Joker g a) where- compare1 = compareJoker compare1--instance Read1 g => Read1 (Joker g a) where- readsPrec1 = readsPrecJoker readsPrec1--instance Show1 g => Show1 (Joker g a) where- showsPrec1 = showsPrecJoker showsPrec1-#endif- eqJoker :: (g b1 -> g b2 -> Bool) -> Joker g a1 b1 -> Joker g a2 b2 -> Bool eqJoker eqB (Joker x) (Joker y) = eqB x y@@ -178,9 +105,17 @@ bifoldMap _ g = foldMap g . runJoker {-# INLINE bifoldMap #-} +instance Foldable1 g => Bifoldable1 (Joker g) where+ bifoldMap1 _ g = foldMap1 g . runJoker+ {-# INLINE bifoldMap1 #-}+ instance Foldable g => Foldable (Joker g a) where foldMap g = foldMap g . runJoker {-# INLINE foldMap #-}++instance Foldable1 g => Foldable1 (Joker g a) where+ foldMap1 g = foldMap1 g . runJoker+ {-# INLINE foldMap1 #-} instance Traversable g => Bitraversable (Joker g) where bitraverse _ g = fmap Joker . traverse g . runJoker
src/Data/Bifunctor/Product.hs view
@@ -1,27 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -42,65 +28,23 @@ 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 Control.Applicative-import Data.Foldable-import Data.Monoid hiding (Product)-import Data.Traversable-#endif--#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif--#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics-#endif--#if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes-#endif+import qualified Data.Semigroup as S+import GHC.Generics 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 Datatype ProductMetaData where- datatypeName _ = "Product"- moduleName _ = "Data.Bifunctor.Product"--instance Constructor ProductMetaCons where- conName _ = "Pair"--instance Generic1 (Product f g a) where- type Rep1 (Product f g a) = D1 ProductMetaData (C1 ProductMetaCons ((:*:)- (S1 NoSelector (Rec1 (f a)))- (S1 NoSelector (Rec1 (g a)))))- from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))- to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)-#endif--#if LIFTED_FUNCTOR_CLASSES instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Product f g a) where liftEq = liftEq2 (==) instance (Eq2 f, Eq2 g) => Eq2 (Product f g) where@@ -128,7 +72,6 @@ showsBinaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) (liftShowsPrec2 sp1 sl1 sp2 sl2) "Pair" p x y-#endif instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where first f (Pair x y) = Pair (first f x) (first f y)@@ -148,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 #-}@@ -185,3 +132,7 @@ instance (A.ArrowPlus p, A.ArrowPlus q) => A.ArrowPlus (Product p q) where Pair x y <+> Pair x' y' = Pair (x A.<+> x') (y A.<+> y')++-- | @since 5.6.1+instance (Swap p, Swap q) => Swap (Product p q) where+ swap (Pair p q) = Pair (swap p) (swap q)
src/Data/Bifunctor/Sum.hs view
@@ -1,91 +1,30 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"+{-# 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.Foldable-import Data.Functor-import Data.Monoid hiding (Sum)-import Data.Traversable-#endif-#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif-#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics-#endif-#if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes-#endif+import GHC.Generics data Sum p q a b = L2 (p a b) | R2 (q a b)- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )+ deriving (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) -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data SumMetaData-data SumMetaConsL2-data SumMetaConsR2--instance Datatype SumMetaData where- datatypeName _ = "Sum"- moduleName _ = "Data.Bifunctor.Sum"--instance Constructor SumMetaConsL2 where- conName _ = "L2"--instance Constructor SumMetaConsR2 where- conName _ = "R2"--instance Generic1 (Sum p q a) where- type Rep1 (Sum p q a) = D1 SumMetaData ((:+:)- (C1 SumMetaConsL2 (S1 NoSelector (Rec1 (p a))))- (C1 SumMetaConsR2 (S1 NoSelector (Rec1 (q a)))))- from1 (L2 p) = M1 (L1 (M1 (M1 (Rec1 p))))- from1 (R2 q) = M1 (R1 (M1 (M1 (Rec1 q))))- to1 (M1 (L1 (M1 (M1 p)))) = L2 (unRec1 p)- to1 (M1 (R1 (M1 (M1 q)))) = R2 (unRec1 q)-#endif--#if LIFTED_FUNCTOR_CLASSES instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Sum f g a) where liftEq = liftEq2 (==) instance (Eq2 f, Eq2 g) => Eq2 (Sum f g) where@@ -116,7 +55,6 @@ showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "L2" p x liftShowsPrec2 sp1 sl1 sp2 sl2 p (R2 y) = showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "R2" p y-#endif instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where bimap f g (L2 p) = L2 (bimap f g p)@@ -144,3 +82,8 @@ bijoin (R2 q) = q bibind _ (L2 p) = L2 p bibind f (R2 q) = f q++-- | @since 5.6.1+instance (Swap p, Swap q) => Swap (Sum p q) where+ swap (L2 p) = L2 (swap p)+ swap (R2 q) = R2 (swap q)
src/Data/Bifunctor/TH.hs view
@@ -2,14 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-}--#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Unsafe #-}-#endif--#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott@@ -86,8 +79,6 @@ -- ^ If 'True', derived instances for empty data types (i.e., ones with -- no data constructors) will use the @EmptyCase@ language extension. -- If 'False', derived instances will simply use 'seq' instead.- -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only- -- available in 7.8 or later.) } deriving (Eq, Ord, Read, Show) -- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to@@ -420,19 +411,13 @@ where makeFun :: Name -> Name -> TyVarMap -> Q Exp makeFun z value tvMap = do-#if MIN_VERSION_template_haskell(2,9,0) roles <- reifyRoles _parentName-#endif case () of- _--#if MIN_VERSION_template_haskell(2,9,0)- | Just (rs, PhantomR) <- unsnoc roles+ _ | Just (rs, PhantomR) <- unsnoc roles , Just (_, PhantomR) <- unsnoc rs -> biFunPhantom z value-#endif - | null cons && emptyCaseBehavior opts && ghc7'8OrLater+ | null cons && emptyCaseBehavior opts -> biFunEmptyCase biFun z value | null cons@@ -442,14 +427,6 @@ -> caseE (varE value) (map (makeBiFunForCon biFun z tvMap) cons) - ghc7'8OrLater :: Bool-#if __GLASGOW_HASKELL__ >= 708- ghc7'8OrLater = True-#else- ghc7'8OrLater = False-#endif--#if MIN_VERSION_template_haskell(2,9,0) biFunPhantom :: Name -> Name -> Q Exp biFunPhantom z value = biFunTrivial coerce@@ -458,7 +435,6 @@ where coerce :: Q Exp coerce = varE coerceValName `appE` varE value-#endif -- | Generates a match for a single constructor. makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match@@ -901,7 +877,7 @@ className :: String className = nameBase $ biClassName biClass --- | One of the last two type variables appeard in a contravariant position+-- | One of the last two type variables appeared in a contravariant position -- when deriving Bifoldable or Bitraversable. contravarianceError :: Name -> Q a contravarianceError conName = fail@@ -1163,10 +1139,8 @@ -- and at least one xr is True | TupleT len <- f -> tuple $ Boxed len-#if MIN_VERSION_template_haskell(2,6,0) | UnboxedTupleT len <- f -> tuple $ Unboxed len-#endif | fc || or (take numFirstArgs xcs) -> wrongArg -- T (..var..) ty_1 ... ty_n | otherwise -- T (..no var..) ty_1 ... ty_n@@ -1197,11 +1171,7 @@ go_kind :: Bool -> Kind -> Q (a, Bool)-#if MIN_VERSION_template_haskell(2,9,0) go_kind = go-#else- go_kind _ _ = trivial-#endif trivial :: Q (a, Bool) trivial = return (caseTrivial, False)@@ -1230,8 +1200,7 @@ -- -- Without the underscore, that code would trigger -Wunused-matches warnings. n <- newName "_n"- body <- lam (VarE n)- return $ LamE [VarP n] body+ lamE [varP n] $ lam (VarE n) -- Make a 'LamE' using two fresh variables. mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp@@ -1246,8 +1215,7 @@ -- Without the underscore, that code would trigger -Wunused-matches warnings. n1 <- newName "_n1" n2 <- newName "n2"- body <- lam (VarE n1) (VarE n2)- return $ LamE [VarP n1, VarP n2] body+ lamE [varP n1, varP n2] $ lam (VarE n1) (VarE n2) -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --@@ -1288,7 +1256,7 @@ varsNeeded <- newNameList "_arg" lengthInsides let pat = conPCompat conName (map VarP varsNeeded) -- Make sure to zip BEFORE invoking catMaybes. We want the variable- -- indicies in each expression to match up with the argument indices+ -- 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)@@ -1319,9 +1287,7 @@ -- corresponds to @Unboxed 3@. data TupleSort = Boxed Int-#if MIN_VERSION_template_haskell(2,6,0) | Unboxed Int-#endif -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: (Name -> [a] -> Q Match)@@ -1329,9 +1295,7 @@ mkSimpleTupleCase matchForCon tupSort insides x = do let tupDataName = case tupSort of Boxed len -> tupleDataName len-#if MIN_VERSION_template_haskell(2,6,0) Unboxed len -> unboxedTupleDataName len-#endif m <- matchForCon tupDataName insides return $ CaseE x [m]
src/Data/Bifunctor/TH/Internal.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Unsafe #-}-#endif {-| Module: Data.Bifunctor.TH.Internal@@ -15,11 +12,17 @@ -} module Data.Bifunctor.TH.Internal where +import Control.Applicative+import Data.Bifunctor (Bifunctor(..))+import Data.Bifoldable (Bifoldable(..))+import Data.Bitraversable (Bitraversable(..))+import Data.Coerce (coerce) import Data.Foldable (foldr') import qualified Data.List as List import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe)+import Data.Monoid (Dual(..), Endo(..)) import qualified Data.Set as Set import Data.Set (Set) @@ -27,26 +30,12 @@ import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax --- Ensure, beyond a shadow of a doubt, that the instances are in-scope-import Data.Bifunctor ()-import Data.Bifoldable ()-import Data.Bitraversable ()--#ifndef CURRENT_PACKAGE_KEY-import Data.Version (showVersion)-import Paths_bifunctors (version)-#endif- ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- applySubstitutionKind :: Map Name Kind -> Type -> Type-#if MIN_VERSION_template_haskell(2,8,0) applySubstitutionKind = applySubstitution-#else-applySubstitutionKind _ t = t-#endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = applySubstitutionKind (Map.singleton n k)@@ -89,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.@@ -153,21 +140,13 @@ -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True-#if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#endif isStarOrVar _ = False -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form@@ -206,11 +185,7 @@ -- | 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:@@ -271,25 +246,10 @@ go tcName = do info <- reify tcName case info of-#if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ bndrs _) _- -> withinFirstArgs bndrs-#else- TyConI (FamilyD TypeFam _ bndrs _)- -> withinFirstArgs bndrs-#endif--#if MIN_VERSION_template_haskell(2,11,0) FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,9,0)- FamilyI (ClosedTypeFamilyD _ bndrs _ _) _- -> withinFirstArgs bndrs-#endif- _ -> return False where withinFirstArgs :: [a] -> Q Bool@@ -316,21 +276,13 @@ 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@@ -357,10 +309,8 @@ go :: Type -> Type -> [Type] -> (Type, [Type]) go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) go origTy (SigT ty' _) args = go origTy ty' args-#if MIN_VERSION_template_haskell(2,11,0) go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args go origTy (ParensT ty') args = go origTy ty' args-#endif go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this:@@ -386,189 +336,113 @@ -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind]-#if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy-#else-uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2-uncurryKind k = [k]-#endif ---------------------------------------------------------------------------------- Manually quoted names+-- Quoted names ------------------------------------------------------------------------------- --- By manually generating these names we avoid needing to use the--- TemplateHaskell language extension when compiling the bifunctors library.--- This allows the library to be used in stage1 cross-compilers.--bifunctorsPackageKey :: String-#ifdef CURRENT_PACKAGE_KEY-bifunctorsPackageKey = CURRENT_PACKAGE_KEY-#else-bifunctorsPackageKey = "bifunctors-" ++ showVersion version-#endif--mkBifunctorsName_tc :: String -> String -> Name-mkBifunctorsName_tc = mkNameG_tc bifunctorsPackageKey--mkBifunctorsName_v :: String -> String -> Name-mkBifunctorsName_v = mkNameG_v bifunctorsPackageKey- bimapConstValName :: Name-bimapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bimapConst"+bimapConstValName = 'bimapConst bifoldrConstValName :: Name-bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst"+bifoldrConstValName = 'bifoldrConst bifoldMapConstValName :: Name-bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst"+bifoldMapConstValName = 'bifoldMapConst coerceValName :: Name-coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"+coerceValName = 'coerce bitraverseConstValName :: Name-bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst"+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"+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 seqValName :: Name-seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"+seqValName = 'seq traverseValName :: Name-traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"+traverseValName = 'traverse unwrapMonadValName :: Name-unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"+unwrapMonadValName = 'unwrapMonad -#if MIN_VERSION_base(4,8,0) bifunctorTypeName :: Name-bifunctorTypeName = mkNameG_tc "base" "Data.Bifunctor" "Bifunctor"--bimapValName :: Name-bimapValName = mkNameG_v "base" "Data.Bifunctor" "bimap"--pureValName :: Name-pureValName = mkNameG_v "base" "GHC.Base" "pure"--apValName :: Name-apValName = mkNameG_v "base" "GHC.Base" "<*>"--liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2"--mappendValName :: Name-mappendValName = mkNameG_v "base" "GHC.Base" "mappend"--memptyValName :: Name-memptyValName = mkNameG_v "base" "GHC.Base" "mempty"-#else-bifunctorTypeName :: Name-bifunctorTypeName = mkBifunctorsName_tc "Data.Bifunctor" "Bifunctor"+bifunctorTypeName = ''Bifunctor bimapValName :: Name-bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap"+bimapValName = 'bimap pureValName :: Name-pureValName = mkNameG_v "base" "Control.Applicative" "pure"+pureValName = 'pure apValName :: Name-apValName = mkNameG_v "base" "Control.Applicative" "<*>"+apValName = '(<*>) liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"+liftA2ValName = 'liftA2 mappendValName :: Name-mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"+mappendValName = 'mappend memptyValName :: Name-memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"-#endif+memptyValName = 'mempty -#if MIN_VERSION_base(4,10,0) bifoldableTypeName :: Name-bifoldableTypeName = mkNameG_tc "base" "Data.Bifoldable" "Bifoldable"--bitraversableTypeName :: Name-bitraversableTypeName = mkNameG_tc "base" "Data.Bitraversable" "Bitraversable"--bifoldrValName :: Name-bifoldrValName = mkNameG_v "base" "Data.Bifoldable" "bifoldr"--bifoldMapValName :: Name-bifoldMapValName = mkNameG_v "base" "Data.Bifoldable" "bifoldMap"--bitraverseValName :: Name-bitraverseValName = mkNameG_v "base" "Data.Bitraversable" "bitraverse"-#else-bifoldableTypeName :: Name-bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable"+bifoldableTypeName = ''Bifoldable bitraversableTypeName :: Name-bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable"+bitraversableTypeName = ''Bitraversable bifoldrValName :: Name-bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr"+bifoldrValName = 'bifoldr bifoldMapValName :: Name-bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap"+bifoldMapValName = 'bifoldMap bitraverseValName :: Name-bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse"-#endif+bitraverseValName = 'bitraverse -#if MIN_VERSION_base(4,11,0) appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo"--dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual"--endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo"--getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual"-#else-appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"+appEndoValName = 'appEndo dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"+dualDataName = 'Dual endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"+endoDataName = 'Endo getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"-#endif+getDualValName = 'getDual
src/Data/Bifunctor/Tannen.hs view
@@ -1,26 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"- ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett@@ -43,68 +29,23 @@ 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 -#if LIFTED_FUNCTOR_CLASSES-import Data.Functor.Classes-#endif- import Prelude hiding ((.),id) -- | Compose a 'Functor' on the outside of a 'Bifunctor'. newtype Tannen f p a b = Tannen { runTannen :: f (p a b) }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable-#endif- )-#if __GLASGOW_HASKELL__ >= 702-# if __GLASGOW_HASKELL__ >= 708+ deriving (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 Constructor TannenMetaCons where- conName _ = "Tannen"- conIsRecord _ = True--instance Selector TannenMetaSel where- selName _ = "runTannen"--instance Functor f => Generic1 (Tannen f p a) where- type Rep1 (Tannen f p a) = D1 TannenMetaData (C1 TannenMetaCons- (S1 TannenMetaSel (f :.: Rec1 (p a))))- from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runTannen- to1 = Tannen . fmap unRec1 . unComp1 . unM1 . unM1 . unM1-# endif-#endif--#if LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq2 p, Eq a) => Eq1 (Tannen f p a) where liftEq = liftEq2 (==) instance (Eq1 f, Eq2 p) => Eq2 (Tannen f p) where@@ -135,7 +76,6 @@ . liftShowsPrec (liftShowsPrec2 sp1 sl1 sp2 sl2) (liftShowList2 sp1 sl1 sp2 sl2) 0 x . showChar '}'-#endif instance Functor f => BifunctorFunctor (Tannen f) where bifmap f (Tannen fp) = Tannen (fmap f fp)@@ -175,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 #-}@@ -209,3 +153,6 @@ instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g) +-- | @since 5.6.1+instance (Functor f, Swap p) => Swap (Tannen f p) where+ swap = Tannen . fmap swap . runTannen
src/Data/Bifunctor/Wrapped.hs view
@@ -1,22 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PolyKinds #-}-#endif--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-#include "bifunctors-common.h"+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -32,69 +18,17 @@ ( 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 GHC.Generics-#endif--#if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes-#endif+import GHC.Generics -- | Make a 'Functor' over the second argument of a 'Bifunctor'. newtype WrappedBifunctor p a b = WrapBifunctor { unwrapBifunctor :: p a b }- deriving ( Eq, Ord, Show, Read-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif-#if __GLASGOW_HASKELL__ >= 708- , Generic1- , Typeable-#endif- )--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708-data WrappedBifunctorMetaData-data WrappedBifunctorMetaCons-data WrappedBifunctorMetaSel--instance Datatype WrappedBifunctorMetaData where- datatypeName = const "WrappedBifunctor"- moduleName = const "Data.Bifunctor.Wrapped"--instance Constructor WrappedBifunctorMetaCons where- conName = const "WrapBifunctor"- conIsRecord = const True--instance Selector WrappedBifunctorMetaSel where- selName = const "unwrapBifunctor"--instance Generic1 (WrappedBifunctor p a) where- type Rep1 (WrappedBifunctor p a) = D1 WrappedBifunctorMetaData- (C1 WrappedBifunctorMetaCons- (S1 WrappedBifunctorMetaSel (Rec1 (p a))))- from1 = M1 . M1 . M1 . Rec1 . unwrapBifunctor- to1 = WrapBifunctor . unRec1 . unM1 . unM1 . unM1-#endif+ deriving (Eq, Ord, Show, Read, Generic, Generic1) -#if LIFTED_FUNCTOR_CLASSES instance (Eq2 p, Eq a) => Eq1 (WrappedBifunctor p a) where liftEq = liftEq2 (==) instance Eq2 p => Eq2 (WrappedBifunctor p) where@@ -123,7 +57,6 @@ showString "WrapBifunctor {unwrapBifunctor = " . liftShowsPrec2 sp1 sl1 sp2 sl2 0 x . showChar '}'-#endif instance Bifunctor p => Bifunctor (WrappedBifunctor p) where first f = WrapBifunctor . first f . unwrapBifunctor@@ -150,6 +83,10 @@ instance Bifoldable p => Bifoldable (WrappedBifunctor p) where bifoldMap f g = bifoldMap f g . unwrapBifunctor {-# INLINE bifoldMap #-}++instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where+ bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor+ {-# INLINE bifoldMap1 #-} instance Bitraversable p => Traversable (WrappedBifunctor p a) where traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor
tests/BifunctorSpec.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,22 +9,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE RoleAnnotations #-}-#endif -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -fno-warn-unused-foralls #-}-#endif+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+{-# OPTIONS_GHC -Wno-unused-foralls #-} {-| Module: BifunctorSpec@@ -54,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@@ -170,9 +159,7 @@ data Empty2 a b deriving (Functor, Foldable, Traversable)-#if __GLASGOW_HASKELL__ >= 708 type role Empty2 nominal nominal-#endif data TyCon81 a b = TyCon81a (forall c. c -> (forall d. a -> d) -> a)@@ -196,13 +183,7 @@ | T3Fam [[a]] [[b]] [[c]] -- nested lists | T4Fam (c,(b,b),(c,c)) -- tuples | T5Fam ([c],Strange a b c) -- tycons-#if __GLASGOW_HASKELL__ >= 708- -- Unfortunately, pre-7.8 versions of GHC suffer from a bug that prevents- -- deriving Functor for data family instances. We could write all of the- -- derived instances by hand, but that amount of boilerplate makes me- -- nauseous. Instead, I elect to guard the derived instances with CPP. deriving (Functor, Foldable, Traversable)-#endif data family StrangeFunctionsFam x y z data instance StrangeFunctionsFam a b c@@ -210,9 +191,7 @@ | T7Fam (a -> (c,a)) -- functions and tuples | T8Fam ((b -> a) -> c) -- continuation | T9Fam (IntFun b c) -- type synonyms-#if __GLASGOW_HASKELL__ >= 708 deriving Functor-#endif data family StrangeGADTFam x y data instance StrangeGADTFam a b where@@ -235,16 +214,12 @@ = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) | S2Fam a | S3Fam b-#if __GLASGOW_HASKELL__ >= 708 deriving (Functor, Foldable, Traversable)-#endif data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b)) deriving ( Arbitrary, Eq, Show-#if __GLASGOW_HASKELL__ >= 708 , Functor, Foldable, Traversable-#endif ) data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y@@ -296,25 +271,12 @@ data instance IntHashFam a b = IntHashFam Int# Int# | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int))-#if __GLASGOW_HASKELL__ >= 708- deriving (Functor, Foldable)--- Old versions of GHC are unable to derive Traversable instances for data types--- with fields of unlifted types, so write this one by hand.-instance Traversable (IntHashFam a) where- traverse f (IntHashFam x y) = pure (IntHashFam x y)- traverse f (IntHashTupleFam x y z (a,b,c,d)) =- (\z' b' d' -> IntHashTupleFam x y z' (a,b',c,d'))- `fmap` f z- <*> f b- <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d-#endif+ deriving (Functor, Foldable, Traversable) data family IntHashFunFam x y data instance IntHashFunFam a b = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)-#if __GLASGOW_HASKELL__ >= 708 deriving Functor-#endif data family TyFamily81 x y data instance TyFamily81 a b@@ -326,9 +288,7 @@ data family TyFamily82 x y data instance TyFamily82 a b = TyFamily82 (F a b)-#if __GLASGOW_HASKELL__ >= 708 deriving (Functor, Foldable, Traversable)-#endif ------------------------------------------------------------------------------- @@ -404,7 +364,6 @@ $(deriveBifoldable ''TyCon82) $(deriveBitraversable ''TyCon82) -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveBifunctor 'T1Fam)@@ -467,7 +426,6 @@ $(deriveBifunctor 'TyFamily82) $(deriveBifoldable 'TyFamily82) $(deriveBitraversable 'TyFamily82)-#endif ------------------------------------------------------------------------------- @@ -531,7 +489,6 @@ (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws" (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation)-#if MIN_VERSION_template_haskell(2,7,0) describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws" (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)@@ -539,4 +496,3 @@ (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws" (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)-#endif