bifunctors

.gitignore

@@ -0,0 +1,2 @@
+_darcs
+dist

Data/Bifoldable.hs

@@ -0,0 +1,104 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Bifoldable
+-- Copyright   :  (C) 2011 Edward Kmett,
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+----------------------------------------------------------------------------
+module Data.Bifoldable 
+  ( Bifoldable(..)
+  , bifoldr'
+  , bifoldrM
+  , bifoldl'
+  , bifoldlM
+  , bitraverse_
+  , bifor_
+  , bimapM_
+  , bisequenceA_
+  , bisequence_
+  , biList
+  , biconcat
+  , biconcatMap
+  , biany
+  , biall
+  ) where
+
+import Control.Applicative
+import Data.Monoid
+
+class Bifoldable p where
+  bifold :: Monoid m => p m m -> m
+  bifold = bifoldMap id id
+
+  bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m
+  bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty
+
+  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
+
+  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
+
+instance Bifoldable (,) where
+  bifoldMap f g (a, b) = f a `mappend` g b
+
+instance Bifoldable Either where
+  bifoldMap f _ (Left a) = f a
+  bifoldMap _ g (Right b) = g b
+
+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
+
+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
+
+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
+
+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
+
+bitraverse_ :: (Bifoldable t, Applicative f) => (a -> f c) -> (b -> f d) -> t a b -> f ()
+bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())
+
+bifor_ :: (Bifoldable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f ()
+bifor_ t f g = bitraverse_ f g t
+
+bimapM_:: (Bifoldable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m ()
+bimapM_ f g = bifoldr ((>>) . f) ((>>) . g) (return ())
+
+biforM_ :: (Bifoldable t, Monad m) => t a b ->  (a -> m c) -> (b -> m d) -> m ()
+biforM_ t f g = bimapM_ f g t
+
+bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()
+bisequenceA_ = bifoldr (*>) (*>) (pure ())
+
+bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m ()
+bisequence_ = bifoldr (>>) (>>) (return ())
+
+biList :: Bifoldable t => t a a -> [a]
+biList = bifoldr (:) (:) []
+
+biconcat :: Bifoldable t => t [a] [a] -> [a]
+biconcat = bifold
+
+biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c]
+biconcatMap = bifoldMap 
+
+biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool
+biany p q = getAny . bifoldMap (Any . p) (Any . q)
+
+biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool
+biall p q = getAll . bifoldMap (All . p) (All . q)

Data/Bifunctor.hs

@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Bifunctor
+-- Copyright   :  (C) 2008-2011 Edward Kmett,
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+----------------------------------------------------------------------------
+module Data.Bifunctor (Bifunctor(..)) where
+
+import Control.Applicative
+
+-- | Minimal definition either 'bimap' or 'first' and 'second'
+class Bifunctor p where
+  bimap :: (a -> b) -> (c -> d) -> p a c -> p b d
+  bimap f g = first f . second g
+
+  first :: (a -> b) -> p a c -> p b c
+  first f = bimap f id
+
+  second :: (b -> c) -> p a b -> p a c
+  second = bimap id 
+
+instance Bifunctor (,) where
+  bimap f g (a, b) = (f a, g b)
+
+instance Bifunctor ((,,) x) where
+  bimap f g (x, a, b) = (x, f a, g b)
+
+instance Bifunctor ((,,,) x y) where
+  bimap f g (x, y, a, b) = (x, y, f a, g b)
+
+instance Bifunctor ((,,,,) x y z) where
+  bimap f g (x, y, z, a, b) = (x, y, z, f a, g b)
+
+instance Bifunctor Either where
+  bimap f _ (Left a) = Left (f a)
+  bimap _ g (Right b) = Right (g b)
+
+instance Bifunctor Const where
+  bimap f _ (Const a) = Const (f a)

Data/Bitraversable.hs

@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Bitraversable
+-- Copyright   :  (C) 2011 Edward Kmett,
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+----------------------------------------------------------------------------
+module Data.Bitraversable
+  ( Bitraversable(..)
+  , bifor
+  , biforM
+  , bimapAccumL
+  , bimapAccumR
+  , bimapDefault
+  , bifoldMapDefault
+  ) where
+
+import Control.Applicative
+import Data.Monoid
+import Data.Bifunctor
+import Data.Bifoldable
+
+class (Bifunctor t, Bifoldable t) => Bitraversable t where
+  bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
+  bitraverse f g = bisequenceA . bimap f g
+
+  bisequenceA :: Applicative f => t (f a) (f b) -> f (t a b)
+  bisequenceA = bitraverse id id
+
+  bimapM :: Monad m => (a -> m c) -> (b -> m d) -> t a b -> m (t c d)
+  bimapM f g = unwrapMonad . bitraverse (WrapMonad . f) (WrapMonad . g)
+
+  bisequence :: Monad m => t (m a) (m b) -> m (t a b)
+  bisequence = bimapM id id
+
+instance Bitraversable (,) where
+  bitraverse f g (a, b) = (,) <$> f a <*> g b
+
+instance Bitraversable Either where
+  bitraverse f _ (Left a) = Left <$> f a
+  bitraverse _ g (Right b) = Right <$> g b
+
+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 :: (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
+
+
+-- 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)
+
+instance Applicative (StateL s) where
+        pure x = StateL (\ s -> (s, x))
+        StateL kf <*> StateL kv = StateL $ \ s ->
+                let (s', f) = kf s
+                    (s'', v) = kv s'
+                in (s'', f v)
+
+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
+
+-- 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)
+
+instance Applicative (StateR s) where
+        pure x = StateR (\ s -> (s, x))
+        StateR kf <*> StateR kv = StateR $ \ s ->
+                let (s', v) = kv s
+                    (s'', f) = kf s'
+                in (s'', f v)
+
+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
+
+newtype Id a = Id { getId :: a }
+
+instance Functor Id where
+        fmap f (Id x) = Id (f x)
+
+instance Applicative Id where
+        pure = Id
+        Id f <*> Id x = Id (f x)
+
+bimapDefault :: Bitraversable t => (a -> b) -> (c -> d) -> t a c -> t b d
+bimapDefault f g = getId . bitraverse (Id . f) (Id . g)
+
+bifoldMapDefault :: (Bitraversable t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m 
+bifoldMapDefault f g = getConst . bitraverse (Const . f) (Const . g)

LICENSE

@@ -0,0 +1,30 @@
+Copyright 2008-2011 Edward Kmett
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.

Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/runhaskell
+> module Main (main) where
+
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

bifunctors.cabal

@@ -0,0 +1,29 @@
+name:          bifunctors
+category:      Data, Functors
+version:       0.1
+license:       BSD3
+cabal-version: >= 1.6
+license-file:  LICENSE
+author:        Edward A. Kmett
+maintainer:    Edward A. Kmett <ekmett@gmail.com>
+stability:     provisional
+homepage:      http://github.com/ekmett/bifunctors/
+copyright:     Copyright (C) 2008-2011 Edward A. Kmett
+synopsis:      Haskell 98 bifunctors
+description:   Haskell 98 bifunctors
+build-type:    Simple
+
+source-repository head
+  type: git
+  location: git://github.com/ekmett/bifunctors.git
+
+library
+  build-depends: 
+    base >= 4 && < 4.4
+
+  exposed-modules:
+    Data.Bifunctor
+    Data.Bifoldable
+    Data.Bitraversable
+
+  ghc-options: -Wall