bifunctor-classes-compat (empty) → 0.1
raw patch · 7 files changed
+1137/−0 lines, 7 filesdep +basedep +base-orphansdep +ghc-prim
Dependencies added: base, base-orphans, ghc-prim, semigroups, tagged, transformers, transformers-compat
Files
- CHANGELOG.markdown +7/−0
- LICENSE +30/−0
- README.markdown +20/−0
- bifunctor-classes-compat.cabal +88/−0
- old-src/ghc709/Data/Bifunctor.hs +185/−0
- old-src/ghc801/Data/Bifoldable.hs +487/−0
- old-src/ghc801/Data/Bitraversable.hs +320/−0
+ CHANGELOG.markdown view
@@ -0,0 +1,7 @@+# Revision history for bifunctor-classes-compat + +## 0.1 -- 2023-01-29 + +* Port the `Bifunctor`, `Bifoldable`, and `Bitraversable` classes from the + [`bifunctors`](https://hackage.haskell.org/package/bifunctors) library into + a smaller package with fewer dependencies.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Edward A. Kmett + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward A. Kmett nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,20 @@+# `bifunctor-classes-compat` +[][Hackage: bifunctor-classes-compat] +[](http://packdeps.haskellers.com/reverse/bifunctor-classes-compat) +[][Haskell.org] +[][tl;dr Legal: BSD3] +[](https://github.com/haskell-compat/bifunctor-classes-compat/actions?query=workflow%3AHaskell-CI) + +[Hackage: bifunctor-classes-compat]: + http://hackage.haskell.org/package/bifunctor-classes-compat + "bifunctor-classes-compat package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" + +Compatibility package for the `Bifunctor`, `Bifoldable`, and `Bitraversable` +classes. See the [`bifunctors`](http://hackage.haskell.org/package/bifunctors) +library for additional `Bifunctor`-related utilities.
+ bifunctor-classes-compat.cabal view
@@ -0,0 +1,88 @@+cabal-version: 1.24 +name: bifunctor-classes-compat +version: 0.1 +synopsis: Compatibility package for the Bifunctor, Bifoldable, and Bitraversable classes +description: Compatibility package for the @Bifunctor@, @Bifoldable@, + and @Bitraversable@ classes. See the + @<http://hackage.haskell.org/package/bifunctors bifunctors>@ + library for additional @Bifunctor@-related utilities. +stability: provisional +homepage: https://github.com/haskell-compat/bifunctor-classes-compat +bug-reports: https://github.com/haskell-compat/bifunctor-classes-compat/issues +license: BSD3 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Ryan Scott <ryan.gl.scott@gmail.com> +copyright: Copyright (C) 2008-2023 Edward A. Kmett +category: Data, Functors +build-type: Simple +tested-with: GHC == 7.0.4 + , GHC == 7.2.2 + , GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.5 + , GHC == 9.4.4 + , GHC == 9.6.1 +extra-source-files: + CHANGELOG.markdown + README.markdown + +source-repository head + type: git + location: https://github.com/haskell-compat/bifunctor-classes-compat.git + +flag semigroups + default: True + manual: True + description: + You can disable the use of the `semigroups` package using `-f-semigroups`. + . + Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + +flag tagged + default: True + manual: True + description: + You can disable the use of the `tagged` package using `-f-tagged`. + . + Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + +library + build-depends: + base >= 4.3 && < 5, + base-orphans >= 0.8.4 && < 1, + transformers >= 0.3 && < 0.7 + + if !impl(ghc > 8.2) + build-depends: transformers-compat >= 0.5 && < 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 + + if impl(ghc>=7.2) && impl(ghc<7.5) + build-depends: ghc-prim == 0.2.0.0 + + ghc-options: -Wall + default-language: Haskell2010
+ old-src/ghc709/Data/Bifunctor.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2008-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Bifunctor + ( -- * Overview + -- + -- Bifunctors extend the standard 'Functor' to two arguments + + -- * Examples + -- $examples + Bifunctor(..) + ) where + +import Control.Applicative +import Data.Functor.Constant +import Data.Semigroup + +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (K1(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import Data.Typeable +#endif + +-- | Minimal definition either 'bimap' or 'first' and 'second' + +-- | Formally, the class 'Bifunctor' represents a bifunctor +-- from @Hask@ -> @Hask@. +-- +-- Intuitively it is a bifunctor where both the first and second arguments are covariant. +-- +-- You can define a 'Bifunctor' by either defining 'bimap' or by defining both +-- 'first' and 'second'. +-- +-- If you supply 'bimap', you should ensure that: +-- +-- @'bimap' 'id' 'id' ≡ 'id'@ +-- +-- If you supply 'first' and 'second', ensure: +-- +-- @ +-- 'first' 'id' ≡ 'id' +-- 'second' 'id' ≡ 'id' +-- @ +-- +-- If you supply both, you should also ensure: +-- +-- @'bimap' f g ≡ 'first' f '.' 'second' g@ +-- +-- These ensure by parametricity: +-- +-- @ +-- 'bimap' (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i +-- 'first' (f '.' g) ≡ 'first' f '.' 'first' g +-- 'second' (f '.' g) ≡ 'second' f '.' 'second' g +-- @ +class Bifunctor p where + -- | Map over both arguments at the same time. + -- + -- @'bimap' f g ≡ 'first' f '.' 'second' g@ + bimap :: (a -> b) -> (c -> d) -> p a c -> p b d + bimap f g = first f . second g + {-# INLINE bimap #-} + + -- | Map covariantly over the first argument. + -- + -- @'first' f ≡ 'bimap' f 'id'@ + first :: (a -> b) -> p a c -> p b c + first f = bimap f id + {-# INLINE first #-} + + -- | Map covariantly over the second argument. + -- + -- @'second' ≡ 'bimap' 'id'@ + second :: (b -> c) -> p a b -> p a c + second = bimap id + {-# INLINE second #-} + +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL bimap | first, second #-} +#endif + +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +deriving instance Typeable Bifunctor +#endif + +instance Bifunctor (,) where + bimap f g ~(a, b) = (f a, g b) + {-# INLINE bimap #-} + +instance Bifunctor Arg where + bimap f g (Arg a b) = Arg (f a) (g b) + +instance Bifunctor ((,,) x) where + bimap f g ~(x, a, b) = (x, f a, g b) + {-# INLINE bimap #-} + +instance Bifunctor ((,,,) x y) where + bimap f g ~(x, y, a, b) = (x, y, f a, g b) + {-# INLINE bimap #-} + +instance Bifunctor ((,,,,) x y z) where + bimap f g ~(x, y, z, a, b) = (x, y, z, f a, g b) + {-# INLINE bimap #-} + +instance Bifunctor ((,,,,,) x y z w) where + bimap f g ~(x, y, z, w, a, b) = (x, y, z, w, f a, g b) + {-# INLINE bimap #-} + +instance Bifunctor ((,,,,,,) x y z w v) where + bimap f g ~(x, y, z, w, v, a, b) = (x, y, z, w, v, f a, g b) + {-# INLINE bimap #-} + +instance Bifunctor Either where + bimap f _ (Left a) = Left (f a) + bimap _ g (Right b) = Right (g b) + {-# INLINE bimap #-} + +instance Bifunctor Const where + bimap f _ (Const a) = Const (f a) + {-# INLINE bimap #-} + +instance Bifunctor Constant where + bimap f _ (Constant a) = Constant (f a) + {-# INLINE bimap #-} + +#if __GLASGOW_HASKELL__ >= 702 +instance Bifunctor (K1 i) where + bimap f _ (K1 c) = K1 (f c) + {-# INLINE bimap #-} +#endif + +#ifdef MIN_VERSION_tagged +instance Bifunctor Tagged where + bimap _ g (Tagged b) = Tagged (g b) + {-# INLINE bimap #-} +#endif + +-- $examples +-- +-- ==== __Examples__ +-- +-- While the standard 'Functor' instance for 'Either' is limited to mapping over 'Right' arguments, +-- the 'Bifunctor' instance allows mapping over the 'Left', 'Right', or both arguments: +-- +-- > let x = Left "foo" :: Either String Integer +-- +-- In the case of 'first' and 'second', the function may or may not be applied: +-- +-- > first (++ "bar") x == Left "foobar" +-- > second (+2) x == Left "foo" +-- +-- In the case of 'bimap', only one of the functions will be applied: +-- +-- > bimap (++ "bar") (+2) x == Left "foobar" +-- +-- The 'Bifunctor' instance for 2 element tuples allows mapping over one or both of the elements: +-- +-- > let x = ("foo",1) +-- > +-- > first (++ "bar") x == ("foobar", 1) +-- > second (+2) x == ("foo", 3) +-- > bimap (++ "bar") (+2) x == ("foobar", 3)
+ old-src/ghc801/Data/Bifoldable.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Bifoldable + ( Bifoldable(..) + , bifoldr' + , bifoldr1 + , bifoldrM + , bifoldl' + , bifoldl1 + , bifoldlM + , bitraverse_ + , bifor_ + , bimapM_ + , biforM_ + , bimsum + , bisequenceA_ + , bisequence_ + , biasum + , biList + , binull + , bilength + , bielem + , bimaximum + , biminimum + , bisum + , biproduct + , biconcat + , biconcatMap + , biand + , bior + , biany + , biall + , bimaximumBy + , biminimumBy + , binotElem + , bifind + ) where + +import Control.Applicative +import Control.Monad +import Data.Functor.Constant +import Data.Maybe (fromMaybe) +import Data.Monoid + +#if MIN_VERSION_base(4,7,0) +import Data.Coerce +#else +import Unsafe.Coerce +#endif + +import Data.Semigroup (Arg(..)) + +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (K1(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +import Data.Typeable +#endif + +-- | 'Bifoldable' identifies foldable structures with two different varieties +-- of elements (as opposed to 'Foldable', which has one variety of element). +-- Common examples are 'Either' and '(,)': +-- +-- > instance Bifoldable Either where +-- > bifoldMap f _ (Left a) = f a +-- > bifoldMap _ g (Right b) = g b +-- > +-- > instance Bifoldable (,) where +-- > bifoldr f g z (a, b) = f a (g b z) +-- +-- A minimal 'Bifoldable' definition consists of either 'bifoldMap' or +-- 'bifoldr'. When defining more than this minimal set, one should ensure +-- that the following identities hold: +-- +-- @ +-- 'bifold' ≡ 'bifoldMap' 'id' 'id' +-- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty' +-- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z +-- @ +-- +-- If the type is also a 'Bifunctor' instance, it should satisfy: +-- +-- > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g +-- +-- which implies that +-- +-- > 'bifoldMap' f g . 'bimap' h i ≡ 'bifoldMap' (f . h) (g . i) +class Bifoldable p where + -- | Combines the elements of a structure using a monoid. + -- + -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@ + bifold :: Monoid m => p m m -> m + bifold = bifoldMap id id + {-# INLINE bifold #-} + + -- | Combines the elements of a structure, given ways of mapping them to a + -- common monoid. + -- + -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@ + bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m + bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty + {-# INLINE bifoldMap #-} + + -- | Combines the elements of a structure in a right associative manner. Given + -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a + -- list of all elements of a structure in order, the following would hold: + -- + -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@ + bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c + bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z + {-# INLINE bifoldr #-} + + -- | Combines the elments of a structure in a left associative manner. Given a + -- hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a + -- list of all elements of a structure in order, the following would hold: + -- + -- @'bifoldl' f g z ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@ + -- + -- Note that if you want an efficient left-fold, you probably want to use + -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not + -- force the "inner" results, resulting in a thunk chain which then must be + -- evaluated from the outside-in. + bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c + bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z + {-# INLINE bifoldl #-} + +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL bifoldr | bifoldMap #-} +#endif + +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +deriving instance Typeable Bifoldable +#endif + +instance Bifoldable Arg where + bifoldMap f g (Arg a b) = f a `mappend` g b + +instance Bifoldable (,) where + bifoldMap f g ~(a, b) = f a `mappend` g b + {-# INLINE bifoldMap #-} + +instance Bifoldable Const where + bifoldMap f _ (Const a) = f a + {-# INLINE bifoldMap #-} + +instance Bifoldable Constant where + bifoldMap f _ (Constant a) = f a + {-# INLINE bifoldMap #-} + +#if __GLASGOW_HASKELL__ >= 702 +instance Bifoldable (K1 i) where + bifoldMap f _ (K1 c) = f c + {-# INLINE bifoldMap #-} +#endif + +instance Bifoldable ((,,) x) where + bifoldMap f g ~(_,a,b) = f a `mappend` g b + {-# INLINE bifoldMap #-} + +instance Bifoldable ((,,,) x y) where + bifoldMap f g ~(_,_,a,b) = f a `mappend` g b + {-# INLINE bifoldMap #-} + +instance Bifoldable ((,,,,) x y z) where + bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b + {-# INLINE bifoldMap #-} + +instance Bifoldable ((,,,,,) x y z w) where + bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b + {-# INLINE bifoldMap #-} + +instance Bifoldable ((,,,,,,) x y z w v) where + bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b + {-# INLINE bifoldMap #-} + +#ifdef MIN_VERSION_tagged +instance Bifoldable Tagged where + bifoldMap _ g (Tagged b) = g b + {-# INLINE bifoldMap #-} +#endif + +instance Bifoldable Either where + bifoldMap f _ (Left a) = f a + bifoldMap _ g (Right b) = g b + {-# INLINE bifoldMap #-} + +-- | As 'bifoldr', but strict in the result of the reduction functions at each +-- step. +bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c +bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where + f' k x z = k $! f x z + g' k x z = k $! g x z +{-# INLINE bifoldr' #-} + +-- | A variant of 'bifoldr' that has no base case, +-- and thus may only be applied to non-empty structures. +bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a +bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure") + (bifoldr mbf mbf Nothing xs) + where + mbf x m = Just (case m of + Nothing -> x + Just y -> f x y) +{-# INLINE bifoldr1 #-} + +-- | Right associative monadic bifold over a structure. +bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c +bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where + f' k x z = f x z >>= k + g' k x z = g x z >>= k +{-# INLINE bifoldrM #-} + +-- | As 'bifoldl', but strict in the result of the reduction functions at each +-- step. +-- +-- This ensures that each step of the bifold is forced to weak head normal form +-- before being applied, avoiding the collection of thunks that would otherwise +-- occur. This is often what you want to strictly reduce a finite structure to +-- a single, monolithic result (e.g., 'bilength'). +bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a +bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where + f' x k z = k $! f z x + g' x k z = k $! g z x +{-# INLINE bifoldl' #-} + +-- | A variant of 'bifoldl' that has no base case, +-- and thus may only be applied to non-empty structures. +bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a +bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure") + (bifoldl mbf mbf Nothing xs) + where + mbf m y = Just (case m of + Nothing -> y + Just x -> f x y) +{-# INLINe bifoldl1 #-} + +-- | Left associative monadic bifold over a structure. +bifoldlM :: (Bifoldable t, Monad m) => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a +bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where + f' x k z = f z x >>= k + g' x k z = g z x >>= k +{-# INLINE bifoldlM #-} + +-- | Map each element of a structure using one of two actions, evaluate these +-- actions from left to right, and ignore the results. For a version that +-- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'. +bitraverse_ :: (Bifoldable t, Applicative f) => (a -> f c) -> (b -> f d) -> t a b -> f () +bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ()) +{-# INLINE bitraverse_ #-} + +-- | As 'bitraverse_', but with the structure as the primary argument. For a +-- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'. +-- +-- >>> > bifor_ ('a', "bc") print (print . reverse) +-- 'a' +-- "cb" +bifor_ :: (Bifoldable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f () +bifor_ t f g = bitraverse_ f g t +{-# INLINE bifor_ #-} + +-- | As 'Data.Bitraversable.bimapM', but ignores the results of the functions, +-- merely performing the "actions". +bimapM_:: (Bifoldable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m () +bimapM_ f g = bifoldr ((>>) . f) ((>>) . g) (return ()) +{-# INLINE bimapM_ #-} + +-- | As 'bimapM_', but with the structure as the primary argument. +biforM_ :: (Bifoldable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m () +biforM_ t f g = bimapM_ f g t +{-# INLINE biforM_ #-} + +-- | As 'Data.Bitraversable.bisequenceA', but ignores the results of the actions. +bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f () +bisequenceA_ = bifoldr (*>) (*>) (pure ()) +{-# INLINE bisequenceA_ #-} + +-- | Evaluate each action in the structure from left to right, and ignore the +-- results. For a version that doesn't ignore the results, see +-- 'Data.Bitraversable.bisequence'. +bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m () +bisequence_ = bifoldr (>>) (>>) (return ()) +{-# INLINE bisequence_ #-} + +-- | The sum of a collection of actions, generalizing 'biconcat'. +biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a +biasum = bifoldr (<|>) (<|>) empty +{-# INLINE biasum #-} + +-- | The sum of a collection of actions, generalizing 'biconcat'. +bimsum :: (Bifoldable t, MonadPlus m) => t (m a) (m a) -> m a +bimsum = bifoldr mplus mplus mzero +{-# INLINE bimsum #-} + +-- | Collects the list of elements of a structure, from left to right. +biList :: Bifoldable t => t a a -> [a] +biList = bifoldr (:) (:) [] +{-# INLINE biList #-} + +-- | Test whether the structure is empty. +binull :: Bifoldable t => t a b -> Bool +binull = bifoldr (\_ _ -> False) (\_ _ -> False) True +{-# INLINE binull #-} + +-- | Returns the size/length of a finite structure as an 'Int'. +bilength :: Bifoldable t => t a b -> Int +bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0 +{-# INLINE bilength #-} + +-- | Does the element occur in the structure? +bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool +bielem x = biany (== x) (== x) +{-# INLINE bielem #-} + +-- | Reduces a structure of lists to the concatenation of those lists. +biconcat :: Bifoldable t => t [a] [a] -> [a] +biconcat = bifold +{-# INLINE biconcat #-} + +newtype Max a = Max {getMax :: Maybe a} +newtype Min a = Min {getMin :: Maybe a} + +instance Ord a => Monoid (Max a) where + mempty = Max Nothing + + {-# INLINE mappend #-} + m `mappend` Max Nothing = m + Max Nothing `mappend` n = n + (Max m@(Just x)) `mappend` (Max n@(Just y)) + | x >= y = Max m + | otherwise = Max n + +instance Ord a => Monoid (Min a) where + mempty = Min Nothing + + {-# INLINE mappend #-} + m `mappend` Min Nothing = m + Min Nothing `mappend` n = n + (Min m@(Just x)) `mappend` (Min n@(Just y)) + | x <= y = Min m + | otherwise = Min n + +-- | The largest element of a non-empty structure. +bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a +bimaximum = fromMaybe (error "bimaximum: empty structure") . + getMax . bifoldMap mj mj + where mj = Max #. (Just :: a -> Maybe a) +{-# INLINE bimaximum #-} + +-- | The least element of a non-empty structure. +biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a +biminimum = fromMaybe (error "biminimum: empty structure") . + getMin . bifoldMap mj mj + where mj = Min #. (Just :: a -> Maybe a) +{-# INLINE biminimum #-} + +-- | The 'bisum' function computes the sum of the numbers of a structure. +bisum :: (Bifoldable t, Num a) => t a a -> a +bisum = getSum #. bifoldMap Sum Sum +{-# INLINE bisum #-} + +-- | The 'biproduct' function computes the product of the numbers of a +-- structure. +biproduct :: (Bifoldable t, Num a) => t a a -> a +biproduct = getProduct #. bifoldMap Product Product +{-# INLINE biproduct #-} + +-- | Given a means of mapping the elements of a structure to lists, computes the +-- concatenation of all such lists in order. +biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c] +biconcatMap = bifoldMap +{-# INLINE biconcatMap #-} + +-- | 'biand' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +biand :: Bifoldable t => t Bool Bool -> Bool +biand = getAll #. bifoldMap All All +{-# INLINE biand #-} + +-- | 'bior' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +bior :: Bifoldable t => t Bool Bool -> Bool +bior = getAny #. bifoldMap Any Any +{-# INLINE bior #-} + +-- | Determines whether any element of the structure satisfies the appropriate +-- predicate. +biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool +biany p q = getAny #. bifoldMap (Any . p) (Any . q) +{-# INLINE biany #-} + +-- | Determines whether all elements of the structure satisfy the appropriate +-- predicate. +biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool +biall p q = getAll #. bifoldMap (All . p) (All . q) +{-# INLINE biall #-} + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a +bimaximumBy cmp = bifoldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y +{-# INLINE bimaximumBy #-} + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a +biminimumBy cmp = bifoldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x +{-# INLINE biminimumBy #-} + +-- | 'binotElem' is the negation of 'bielem'. +binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool +binotElem x = not . bielem x +{-# INLINE binotElem #-} + +-- | The 'bifind' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a +bifind p = getFirst . bifoldMap finder finder + where finder x = First (if p x then Just x else Nothing) +{-# INLINE bifind #-} + +-- See Note [Function coercion] +#if MIN_VERSION_base(4,7,0) +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce +#else +(#.) :: (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = unsafeCoerce +#endif +{-# INLINE (#.) #-} + +{- +Note [Function coercion] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Several functions here use (#.) instead of (.) to avoid potential efficiency +problems relating to #7542. The problem, in a nutshell: + +If N is a newtype constructor, then N x will always have the same +representation as x (something similar applies for a newtype deconstructor). +However, if f is a function, + +N . f = \x -> N (f x) + +This looks almost the same as f, but the eta expansion lifts it--the lhs could +be _|_, but the rhs never is. This can lead to very inefficient code. Thus we +steal a technique from Shachaf and Edward Kmett and adapt it to the current +(rather clean) setting. Instead of using N . f, we use N .## f, which is +just + +coerce f `asTypeOf` (N . f) + +That is, we just *pretend* that f has the right type, and thanks to the safety +of coerce, the type checker guarantees that nothing really goes wrong. We still +have to be a bit careful, though: remember that #. completely ignores the +*value* of its left operand. +-}
+ old-src/ghc801/Data/Bitraversable.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Bitraversable + ( Bitraversable(..) + , bisequenceA + , bisequence + , bimapM + , bifor + , biforM + , bimapAccumL + , bimapAccumR + , bimapDefault + , bifoldMapDefault + ) where + +import Control.Applicative +import Control.Monad.Trans.Instances () +import Data.Bifunctor +import Data.Bifoldable +import Data.Functor.Constant +import Data.Functor.Identity +import Data.Orphans () + +#if MIN_VERSION_base(4,7,0) +import Data.Coerce (coerce) +#else +import Unsafe.Coerce (unsafeCoerce) +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +import Data.Semigroup (Arg(..)) + +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (K1(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +import Data.Typeable +#endif + +-- | 'Bitraversable' identifies bifunctorial data structures whose elements can +-- be traversed in order, performing 'Applicative' or 'Monad' actions at each +-- element, and collecting a result structure with the same shape. +-- +-- As opposed to 'Traversable' data structures, which have one variety of +-- element on which an action can be performed, 'Bitraversable' data structures +-- have two such varieties of elements. +-- +-- A definition of 'bitraverse' must satisfy the following laws: +-- +-- [/naturality/] +-- @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@ +-- for every applicative transformation @t@ +-- +-- [/identity/] +-- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ +-- +-- [/composition/] +-- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2 +-- ≡ 'bitraverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@ +-- +-- where an /applicative transformation/ is a function +-- +-- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@ +-- +-- preserving the 'Applicative' operations: +-- +-- @ +-- t ('pure' x) = 'pure' x +-- t (f '<*>' x) = t f '<*>' t x +-- @ +-- +-- and the identity functor 'Identity' and composition functors 'Compose' are +-- defined as +-- +-- > newtype Identity a = Identity { runIdentity :: a } +-- > +-- > instance Functor Identity where +-- > fmap f (Identity x) = Identity (f x) +-- > +-- > instance Applicative Identity where +-- > pure = Identity +-- > Identity f <*> Identity x = Identity (f x) +-- > +-- > newtype Compose f g a = Compose (f (g a)) +-- > +-- > instance (Functor f, Functor g) => Functor (Compose f g) where +-- > fmap f (Compose x) = Compose (fmap (fmap f) x) +-- > +-- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where +-- > pure = Compose . pure . pure +-- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +-- +-- Some simple examples are 'Either' and '(,)': +-- +-- > instance Bitraversable Either where +-- > bitraverse f _ (Left x) = Left <$> f x +-- > bitraverse _ g (Right y) = Right <$> g y +-- > +-- > instance Bitraversable (,) where +-- > bitraverse f g (x, y) = (,) <$> f x <*> g y +-- +-- 'Bitraversable' relates to its superclasses in the following ways: +-- +-- @ +-- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g) +-- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g) +-- @ +-- +-- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively. +class (Bifunctor t, Bifoldable t) => Bitraversable t where + -- | Evaluates the relevant functions at each element in the structure, running + -- the action, and builds a new structure with the same shape, using the + -- elements produced from sequencing the actions. + -- + -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@ + -- + -- For a version that ignores the results, see 'bitraverse_'. + bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) + + +-- | Sequences all the actions in a structure, building a new structure with the +-- same shape using the results of the actions. For a version that ignores the +-- results, see 'bisequenceA_'. +-- +-- @'bisequenceA' ≡ 'bitraverse' 'id' 'id'@ +bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b) +bisequenceA = bitraverse id id +{-# INLINE bisequenceA #-} + +-- | As 'bitraverse', but uses evidence that @m@ is a 'Monad' rather than an +-- 'Applicative'. For a version that ignores the results, see 'bimapM_'. +-- +-- @ +-- 'bimapM' f g ≡ 'bisequence' . 'bimap' f g +-- 'bimapM' f g ≡ 'unwrapMonad' . 'bitraverse' ('WrapMonad' . f) ('WrapMonad' . g) +-- @ +bimapM :: (Bitraversable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m (t c d) +bimapM f g = unwrapMonad . bitraverse (WrapMonad . f) (WrapMonad . g) +{-# INLINE bimapM #-} + +-- | As 'bisequenceA', but uses evidence that @m@ is a 'Monad' rather than an +-- 'Applicative'. For a version that ignores the results, see 'bisequence_'. +-- +-- @ +-- 'bisequence' ≡ 'bimapM' 'id' 'id' +-- 'bisequence' ≡ 'unwrapMonad' . 'bisequenceA' . 'bimap' 'WrapMonad' 'WrapMonad' +-- @ +bisequence :: (Bitraversable t, Monad m) => t (m a) (m b) -> m (t a b) +bisequence = bimapM id id +{-# INLINE bisequence #-} + +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +deriving instance Typeable Bitraversable +#endif + +instance Bitraversable Arg where + bitraverse f g (Arg a b) = Arg <$> f a <*> g b + +instance Bitraversable (,) where + bitraverse f g ~(a, b) = (,) <$> f a <*> g b + {-# INLINE bitraverse #-} + +instance Bitraversable ((,,) x) where + bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b + {-# INLINE bitraverse #-} + +instance Bitraversable ((,,,) x y) where + bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b + {-# INLINE bitraverse #-} + +instance Bitraversable ((,,,,) x y z) where + bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b + {-# INLINE bitraverse #-} + +instance Bitraversable ((,,,,,) x y z w) where + bitraverse f g ~(x, y, z, w, a, b) = (,,,,,) x y z w <$> f a <*> g b + {-# INLINE bitraverse #-} + +instance Bitraversable ((,,,,,,) x y z w v) where + bitraverse f g ~(x, y, z, w, v, a, b) = (,,,,,,) x y z w v <$> f a <*> g b + {-# INLINE bitraverse #-} + +instance Bitraversable Either where + bitraverse f _ (Left a) = Left <$> f a + bitraverse _ g (Right b) = Right <$> g b + {-# INLINE bitraverse #-} + +instance Bitraversable Const where + bitraverse f _ (Const a) = Const <$> f a + {-# INLINE bitraverse #-} + +instance Bitraversable Constant where + bitraverse f _ (Constant a) = Constant <$> f a + {-# INLINE bitraverse #-} + +#if __GLASGOW_HASKELL__ >= 702 +instance Bitraversable (K1 i) where + bitraverse f _ (K1 c) = K1 <$> f c + {-# INLINE bitraverse #-} +#endif + +#ifdef MIN_VERSION_tagged +instance Bitraversable Tagged where + bitraverse _ g (Tagged b) = Tagged <$> g b + {-# INLINE bitraverse #-} +#endif + +-- | 'bifor' is 'bitraverse' with the structure as the first argument. For a +-- version that ignores the results, see 'bifor_'. +bifor :: (Bitraversable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f (t c d) +bifor t f g = bitraverse f g t +{-# INLINE bifor #-} + +-- | 'biforM' is 'bimapM' with the structure as the first argument. For a +-- version that ignores the results, see 'biforM_'. +biforM :: (Bitraversable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m (t c d) +biforM t f g = bimapM f g t +{-# INLINE biforM #-} + +-- | left-to-right state transformer +newtype StateL s a = StateL { runStateL :: s -> (s, a) } + +instance Functor (StateL s) where + fmap f (StateL k) = StateL $ \ s -> + let (s', v) = k s in (s', f v) + {-# INLINE fmap #-} + +instance Applicative (StateL s) where + pure x = StateL (\ s -> (s, x)) + {-# INLINE pure #-} + StateL kf <*> StateL kv = StateL $ \ s -> + let (s', f) = kf s + (s'', v) = kv s' + in (s'', f v) + {-# INLINE (<*>) #-} + +-- | The 'bimapAccumL' function behaves like a combination of 'bimap' and +-- 'bifoldl'; it traverses a structure from left to right, threading a state +-- of type @a@ and using the given actions to compute new elements for the +-- structure. +bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e) +bimapAccumL f g s t = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s +{-# INLINE bimapAccumL #-} + +-- | right-to-left state transformer +newtype StateR s a = StateR { runStateR :: s -> (s, a) } + +instance Functor (StateR s) where + fmap f (StateR k) = StateR $ \ s -> + let (s', v) = k s in (s', f v) + {-# INLINE fmap #-} + +instance Applicative (StateR s) where + pure x = StateR (\ s -> (s, x)) + {-# INLINE pure #-} + StateR kf <*> StateR kv = StateR $ \ s -> + let (s', v) = kv s + (s'', f) = kf s' + in (s'', f v) + {-# INLINE (<*>) #-} + +-- | The 'bimapAccumR' function behaves like a combination of 'bimap' and +-- 'bifoldl'; it traverses a structure from right to left, threading a state +-- of type @a@ and using the given actions to compute new elements for the +-- structure. +bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e) +bimapAccumR f g s t = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s +{-# INLINE bimapAccumR #-} + +-- | A default definition of 'bimap' in terms of the 'Bitraversable' operations. +-- +-- @'bimapDefault' f g ≡ +-- 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@ +bimapDefault :: forall t a b c d . Bitraversable t + => (a -> b) -> (c -> d) -> t a c -> t b d +bimapDefault = coerce + (bitraverse :: (a -> Identity b) + -> (c -> Identity d) -> t a c -> Identity (t b d)) +{-# INLINE bimapDefault #-} + +-- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' operations. +-- +-- @'bifoldMapDefault' f g ≡ +-- 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@ +bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m) + => (a -> m) -> (b -> m) -> t a b -> m +bifoldMapDefault = coerce + (bitraverse :: (a -> Const m ()) + -> (b -> Const m ()) -> t a b -> Const m (t () ())) +{-# INLINE bifoldMapDefault #-} + +#if !(MIN_VERSION_base(4,7,0)) +coerce :: a -> b +coerce = unsafeCoerce +#endif