[project @ 2005-11-29 14:31:59 by ross]
authorross <unknown>
Tue, 29 Nov 2005 14:31:59 +0000 (14:31 +0000)
committerross <unknown>
Tue, 29 Nov 2005 14:31:59 +0000 (14:31 +0000)
As foreshadowed on the libraries list, introduce new classes:

Applicative (formerly known as Idiom): generalizes (but does not replace)
both Monad and Monoid.

Traversable: containers that can be traversed, executing actions and
re-assembling the results.  This class generalizes and replaces FunctorM,
because it requires Applicative instead of Monad.

Foldable: containers that can be folded over a Monoid.  Traversable
supplies a default definition, but some structures, e.g. Set, are Foldable
but not Traversable.

Control/Applicative.hs [new file with mode: 0644]
Data/Foldable.hs [new file with mode: 0644]
Data/IntMap.hs
Data/Map.hs
Data/Sequence.hs
Data/Set.hs
Data/Traversable.hs [new file with mode: 0644]
Data/Tree.hs
base.cabal
package.conf.in

diff --git a/Control/Applicative.hs b/Control/Applicative.hs
new file mode 100644 (file)
index 0000000..a395314
--- /dev/null
@@ -0,0 +1,151 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Applicative
+-- Copyright   :  Conor McBride and Ross Paterson 2005
+-- License     :  BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  :  ross@soi.city.ac.uk
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This module describes a structure intermediate between a functor and
+-- a monad: it provides pure expressions and sequencing, but no binding.
+-- (Technically, a strong lax monoidal functor.)  For more details, see
+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.
+--
+-- This interface was introduced for parsers by Niklas R&#xF6;jemo, because
+-- it admits more sharing than the monadic interface.  The names here are
+-- mostly based on recent parsing work by Doaitse Swierstra.
+--
+-- This class is also useful with instances of the
+-- 'Data.Traversable.Traversable' class.
+
+module Control.Applicative (
+       -- * Applicative functors
+       Applicative(..),
+       -- * Instances
+       WrappedMonad(..), Const(..), ZipList(..),
+       -- * Utility functions
+       (<$), (*>), (<*), (<**>),
+       liftA, liftA2, liftA3
+       ) where
+
+#ifdef __HADDOCK__
+import Prelude
+#endif
+
+import Control.Monad (liftM, ap)
+import Data.Monoid (Monoid(..))
+
+infixl 4 <$>, <$
+infixl 4 <*>, <*, *>, <**>
+
+-- | A functor with application.
+--
+-- Instances should satisfy the following laws:
+--
+-- [/identity/]
+--     @'pure' 'id' '<*>' v = v@
+--
+-- [/composition/]
+--     @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
+--
+-- [/homomorphism/]
+--     @'pure' f '<*>' 'pure' x = 'pure' (f x)@
+--
+-- [/interchange/]
+--     @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
+--
+-- [/pure application/]
+--     @f '<$>' v = 'pure' f '<*>' v@
+--
+-- Minimal complete definition: 'pure' and '<*>'.
+--
+-- If @f@ is also a 'Functor', define @('<$>') = 'fmap'@.
+-- If it is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@.
+
+class Applicative f where
+       -- | Lift a value.
+       pure :: a -> f a
+
+        -- | Sequential application.
+       (<*>) :: f (a -> b) -> f a -> f b
+
+       -- | Map a function over an action.
+       (<$>) :: (a -> b) -> f a -> f b
+       f <$> v = pure f <*> v
+
+-- instances for Prelude types
+
+instance Applicative Maybe where
+       pure = return
+       (<*>) = ap
+
+instance Applicative [] where
+       pure = return
+       (<*>) = ap
+
+instance Applicative IO where
+       pure = return
+       (<*>) = ap
+
+instance Applicative ((->) a) where
+       pure = const
+       (<*>) f g x = f x (g x)
+
+-- new instances
+
+newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
+
+instance Monad m => Applicative (WrappedMonad m) where
+       pure = WrapMonad . return
+       WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
+       f <$> WrapMonad v = WrapMonad (liftM f v)
+
+newtype Const a b = Const { getConst :: a }
+
+instance Monoid m => Applicative (Const m) where
+       pure _ = Const mempty
+       Const f <*> Const v = Const (f `mappend` v)
+       _ <$> Const v = Const v
+
+-- | Lists, but with an 'Applicative' functor based on zipping, so that
+--
+-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
+--
+newtype ZipList a = ZipList { getZipList :: [a] }
+
+instance Applicative ZipList where
+       pure x = ZipList (repeat x)
+       ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
+       f <$> ZipList xs = ZipList (map f xs)
+
+-- extra functions
+
+-- | Replace the value.
+(<$) :: Applicative f => a -> f b -> f a
+(<$) = (<$>) . const
+-- | Sequence actions, discarding the value of the first argument.
+(*>) :: Applicative f => f a -> f b -> f b
+(*>) = liftA2 (const id)
+-- | Sequence actions, discarding the value of the second argument.
+(<*) :: Applicative f => f a -> f b -> f a
+(<*) = liftA2 const
+-- | A variant of '<*>' with the arguments reversed.
+(<**>) :: Applicative f => f a -> f (a -> b) -> f b
+(<**>) = liftA2 (flip ($))
+
+-- | A synonym for '<$>'.
+liftA :: Applicative f => (a -> b) -> f a -> f b
+liftA f a = f <$> a
+
+-- | Lift a binary function to actions.
+liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
+liftA2 f a b = f <$> a <*> b
+
+-- | Lift a ternary function to actions.
+liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
+liftA3 f a b c = f <$> a <*> b <*> c
diff --git a/Data/Foldable.hs b/Data/Foldable.hs
new file mode 100644 (file)
index 0000000..fcba159
--- /dev/null
@@ -0,0 +1,257 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Foldable
+-- Copyright   :  Ross Paterson 2005
+-- License     :  BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  :  ross@soi.city.ac.uk
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Class of data structures that can be folded to a summary value.
+
+module Data.Foldable (
+       -- * Folds
+       Foldable(..),
+       -- ** Special biased folds
+       foldr',
+       foldl',
+       foldrM,
+       foldlM,
+       -- ** Folding actions
+       traverse_,
+       mapM_,
+       sequenceA_,
+       sequence_,
+       -- ** Specialized folds
+       toList,
+       concat,
+       concatMap,
+       and,
+       or,
+       any,
+       all,
+       sum,
+       product,
+       maximum,
+       maximumBy,
+       minimum,
+       minimumBy,
+       -- ** Searches
+       elem,
+       notElem,
+       find
+       ) where
+
+import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_,
+               elem, notElem, concat, concatMap, and, or, any, all,
+               sum, product, maximum, minimum)
+import qualified Prelude (foldl, foldr, foldl1, foldr1)
+import Control.Applicative
+import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Monoid
+import Data.Array
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (build)
+#endif
+
+-- | Data structures that can be folded.
+--
+-- Minimal complete definition: 'foldMap' or 'foldr'.
+--
+-- For example, given a data type
+--
+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
+--
+-- a suitable instance would be
+--
+-- > instance Foldable Tree
+-- >    foldMap f Empty = mempty
+-- >    foldMap f (Leaf x) = f x
+-- >    foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend foldMap` f r
+--
+-- This is suitable even for abstract types, as the monoid is assumed
+-- to satisfy the monoid laws.
+--
+class Foldable t where
+       -- | Combine the elements of a structure using a monoid.
+       fold :: Monoid m => t m -> m
+       fold = foldMap id
+
+       -- | Map each element of the structure to a monoid,
+       -- and combine the results.
+       foldMap :: Monoid m => (a -> m) -> t a -> m
+       foldMap f = foldr (mappend . f) mempty
+
+       -- | Right-associative fold of a structure.
+       --
+       -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@
+       foldr :: (a -> b -> b) -> b -> t a -> b
+       foldr f z t = appEndo (foldMap (Endo . f) t) z
+
+       -- | Left-associative fold of a structure.
+       --
+       -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@
+       foldl :: (a -> b -> a) -> a -> t b -> a
+       foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z
+
+       -- | A variant of 'foldr' that has no base case,
+       -- and thus may only be applied to non-empty structures.
+       --
+       -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@
+       foldr1 :: (a -> a -> a) -> t a -> a
+       foldr1 f xs = fromMaybe (error "foldr1: empty structure")
+                       (foldr mf Nothing xs)
+         where mf x Nothing = Just x
+               mf x (Just y) = Just (f x y)
+
+       -- | A variant of 'foldl' that has no base case,
+       -- and thus may only be applied to non-empty structures.
+       --
+       -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@
+       foldl1 :: (a -> a -> a) -> t a -> a
+       foldl1 f xs = fromMaybe (error "foldl1: empty structure")
+                       (foldl mf Nothing xs)
+         where mf Nothing y = Just y
+               mf (Just x) y = Just (f x y)
+
+-- instances for Prelude types
+
+instance Foldable Maybe where
+       foldr f z Nothing = z
+       foldr f z (Just x) = f x z
+
+       foldl f z Nothing = z
+       foldl f z (Just x) = f z x
+
+instance Foldable [] where
+       foldr = Prelude.foldr
+       foldl = Prelude.foldl
+       foldr1 = Prelude.foldr1
+       foldl1 = Prelude.foldl1
+
+instance Ix i => Foldable (Array i) where
+       foldr f z = Prelude.foldr f z . elems
+
+-- | Fold over the elements of a structure,
+-- associating to the right, but strictly.
+foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b
+foldr' f z xs = foldl f' id xs z
+  where f' k x z = k $! f x z
+
+-- | Monadic fold over the elements of a structure,
+-- associating to the right, i.e. from right to left.
+foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b
+foldrM f z xs = foldl f' return xs z
+  where f' k x z = f x z >>= k
+
+-- | Fold over the elements of a structure,
+-- associating to the left, but strictly.
+foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a
+foldl' f z xs = foldr f' id xs z
+  where f' x k z = k $! f z x
+
+-- | Monadic fold over the elements of a structure,
+-- associating to the left, i.e. from left to right.
+foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a
+foldlM f z xs = foldr f' return xs z
+  where f' x k z = f z x >>= k
+
+-- | Map each element of a structure to an action, evaluate
+-- these actions from left to right, and ignore the results.
+traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()
+traverse_ f = foldr ((*>) . f) (pure ())
+
+-- | Map each element of a structure to an monadic action, evaluate
+-- these actions from left to right, and ignore the results.
+mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()
+mapM_ f = foldr ((>>) . f) (return ())
+
+-- | Evaluate each action in the structure from left to right,
+-- and ignore the results.
+sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()
+sequenceA_ = foldr (*>) (pure ())
+
+-- | Evaluate each monadic action in the structure from left to right,
+-- and ignore the results.
+sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()
+sequence_ = foldr (>>) (return ())
+
+-- These use foldr rather than foldMap to avoid repeated concatenation.
+
+-- | List of elements of a structure.
+toList :: Foldable t => t a -> [a]
+#ifdef __GLASGOW_HASKELL__
+toList t = build (\ c n -> foldr c n t)
+#else
+toList = foldr (:) []
+#endif
+
+-- | The concatenation of all the elements of a container of lists.
+concat :: Foldable t => t [a] -> [a]
+concat = foldr (++) []
+
+concatMap :: Foldable t => (a -> [b]) -> t a -> [b]
+concatMap f = foldr ((++) . f) []
+
+-- | 'and' 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.
+and :: Foldable t => t Bool -> Bool
+and = getAll . foldMap All
+
+-- | 'or' 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.
+or :: Foldable t => t Bool -> Bool
+or = getAny . foldMap Any
+
+-- | Determines whether any element of the structure satisfies the predicate.
+any :: Foldable t => (a -> Bool) -> t a -> Bool
+any p = getAny . foldMap (Any . p)
+
+-- | Determines whether all elements of the structure satisfy the predicate.
+all :: Foldable t => (a -> Bool) -> t a -> Bool
+all p = getAll . foldMap (All . p)
+
+-- | The 'sum' function computes the sum of the numbers of a structure.
+sum :: (Foldable t, Num a) => t a -> a
+sum = getSum . foldMap Sum
+
+-- | The 'product' function computes the product of the numbers of a structure.
+product :: (Foldable t, Num a) => t a -> a
+product = getProduct . foldMap Product
+
+-- | The largest element of the structure.
+maximum :: (Foldable t, Ord a) => t a -> a
+maximum = foldr1 max
+
+maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a
+maximumBy cmp = foldr1 max'
+  where max' x y = case cmp x y of
+                       GT -> x
+                       _  -> y
+
+-- | The least element of the structure.
+minimum :: (Foldable t, Ord a) => t a -> a
+minimum = foldr1 min
+
+minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a
+minimumBy cmp = foldr1 min'
+  where min' x y = case cmp x y of
+                       GT -> y
+                       _  -> x
+
+-- | Does the element occur in the structure?
+elem :: (Foldable t, Eq a) => a -> t a -> Bool
+elem = any . (==)
+
+notElem :: (Foldable t, Eq a) => a -> t a -> Bool
+notElem x = not . elem x
+
+-- | The 'find' 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.
+find :: Foldable t => (a -> Bool) -> t a -> Maybe a
+find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])
index e210442..1be0bbe 100644 (file)
@@ -138,6 +138,7 @@ import Data.Int
 import qualified Data.IntSet as IntSet
 import Data.Monoid (Monoid(..))
 import Data.Typeable
 import qualified Data.IntSet as IntSet
 import Data.Monoid (Monoid(..))
 import Data.Typeable
+import Data.Foldable (Foldable(foldMap))
 
 {-
 -- just for testing
 
 {-
 -- just for testing
@@ -216,6 +217,11 @@ instance Ord a => Monoid (IntMap a) where
     mappend = union
     mconcat = unions
 
     mappend = union
     mconcat = unions
 
+instance Foldable IntMap where
+    foldMap f Nil = mempty
+    foldMap f (Tip _k v) = f v
+    foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r
+
 #if __GLASGOW_HASKELL__
 
 {--------------------------------------------------------------------
 #if __GLASGOW_HASKELL__
 
 {--------------------------------------------------------------------
index f0b7f6f..da12f9d 100644 (file)
@@ -152,6 +152,9 @@ import qualified Data.Set as Set
 import qualified Data.List as List
 import Data.Monoid (Monoid(..))
 import Data.Typeable
 import qualified Data.List as List
 import Data.Monoid (Monoid(..))
 import Data.Typeable
+import Control.Applicative (Applicative(..))
+import Data.Traversable (Traversable(traverse))
+import Data.Foldable (Foldable(foldMap))
 
 {-
 -- for quick check
 
 {-
 -- for quick check
@@ -1319,6 +1322,16 @@ instance (Ord k, Ord v) => Ord (Map k v) where
 instance Functor (Map k) where
   fmap f m  = map f m
 
 instance Functor (Map k) where
   fmap f m  = map f m
 
+instance Traversable (Map k) where
+  traverse f Tip = pure Tip
+  traverse f (Bin s k v l r)
+    = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
+
+instance Foldable (Map k) where
+  foldMap _f Tip = mempty
+  foldMap f (Bin _s _k v l r)
+    = foldMap f l `mappend` f v `mappend` foldMap f r
+
 {--------------------------------------------------------------------
   Read
 --------------------------------------------------------------------}
 {--------------------------------------------------------------------
   Read
 --------------------------------------------------------------------}
index c68a6ad..d072a28 100644 (file)
@@ -39,6 +39,7 @@ module Data.Sequence (
        (<|),           -- :: a -> Seq a -> Seq a
        (|>),           -- :: Seq a -> a -> Seq a
        (><),           -- :: Seq a -> Seq a -> Seq a
        (<|),           -- :: a -> Seq a -> Seq a
        (|>),           -- :: Seq a -> a -> Seq a
        (><),           -- :: Seq a -> Seq a -> Seq a
+       fromList,       -- :: [a] -> Seq a
        -- * Deconstruction
        -- ** Queries
        null,           -- :: Seq a -> Bool
        -- * Deconstruction
        -- ** Queries
        null,           -- :: Seq a -> Bool
@@ -55,20 +56,6 @@ module Data.Sequence (
        take,           -- :: Int -> Seq a -> Seq a
        drop,           -- :: Int -> Seq a -> Seq a
        splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)
        take,           -- :: Int -> Seq a -> Seq a
        drop,           -- :: Int -> Seq a -> Seq a
        splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)
-       -- * Lists
-       fromList,       -- :: [a] -> Seq a
-       toList,         -- :: Seq a -> [a]
-       -- * Folds
-       -- ** Right associative
-       foldr,          -- :: (a -> b -> b) -> b -> Seq a -> b
-       foldr1,         -- :: (a -> a -> a) -> Seq a -> a
-       foldr',         -- :: (a -> b -> b) -> b -> Seq a -> b
-       foldrM,         -- :: Monad m => (a -> b -> m b) -> b -> Seq a -> m b
-       -- ** Left associative
-       foldl,          -- :: (a -> b -> a) -> a -> Seq b -> a
-       foldl1,         -- :: (a -> a -> a) -> Seq a -> a
-       foldl',         -- :: (a -> b -> a) -> a -> Seq b -> a
-       foldlM,         -- :: Monad m => (a -> b -> m a) -> a -> Seq b -> m a
        -- * Transformations
        reverse,        -- :: Seq a -> Seq a
 #if TESTING
        -- * Transformations
        reverse,        -- :: Seq a -> Seq a
 #if TESTING
@@ -80,13 +67,14 @@ import Prelude hiding (
        null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
        reverse)
 import qualified Data.List (foldl')
        null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
        reverse)
 import qualified Data.List (foldl')
-import Control.Monad (MonadPlus(..), liftM2)
+import Control.Applicative (Applicative(..))
+import Control.Monad (MonadPlus(..))
 import Data.Monoid (Monoid(..))
 import Data.Monoid (Monoid(..))
-import Data.FunctorM
+import Data.Foldable
+import Data.Traversable
 import Data.Typeable
 
 #ifdef __GLASGOW_HASKELL__
 import Data.Typeable
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Exts (build)
 import Text.Read (Lexeme(Ident), lexP, parens, prec,
        readPrec, readListPrec, readListPrecDefault)
 import Data.Generics.Basics (Data(..), Fixity(..),
 import Text.Read (Lexeme(Ident), lexP, parens, prec,
        readPrec, readListPrec, readListPrecDefault)
 import Data.Generics.Basics (Data(..), Fixity(..),
@@ -112,7 +100,20 @@ class Sized a where
 newtype Seq a = Seq (FingerTree (Elem a))
 
 instance Functor Seq where
 newtype Seq a = Seq (FingerTree (Elem a))
 
 instance Functor Seq where
-       fmap f (Seq xs) = Seq (fmap (fmap f) xs)
+       fmap = fmapDefault
+
+instance Foldable Seq where
+       foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
+       foldl f z (Seq xs) = foldl (foldl f) z xs
+
+       foldr1 f (Seq xs) = getElem (foldr1 f' xs)
+         where f' (Elem x) (Elem y) = Elem (f x y)
+
+       foldl1 f (Seq xs) = getElem (foldl1 f' xs)
+         where f' (Elem x) (Elem y) = Elem (f x y)
+
+instance Traversable Seq where
+       traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
 
 instance Monad Seq where
        return = singleton
 
 instance Monad Seq where
        return = singleton
@@ -123,14 +124,6 @@ instance MonadPlus Seq where
        mzero = empty
        mplus = (><)
 
        mzero = empty
        mplus = (><)
 
-instance FunctorM Seq where
-       fmapM f = foldlM f' empty
-         where f' ys x = do
-                       y <- f x
-                       return $! (ys |> y)
-       fmapM_ f = foldlM f' ()
-         where f' _ x = f x >> return ()
-
 instance Eq a => Eq (Seq a) where
        xs == ys = length xs == length ys && toList xs == toList ys
 
 instance Eq a => Eq (Seq a) where
        xs == ys = length xs == length ys && toList xs == toList ys
 
@@ -209,11 +202,33 @@ instance Sized a => Sized (FingerTree a) where
        size (Single x)         = size x
        size (Deep v _ _ _)     = v
 
        size (Single x)         = size x
        size (Deep v _ _ _)     = v
 
-instance Functor FingerTree where
-       fmap _ Empty = Empty
-       fmap f (Single x) = Single (f x)
-       fmap f (Deep v pr m sf) =
-               Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
+instance Foldable FingerTree where
+       foldr _ z Empty = z
+       foldr f z (Single x) = x `f` z
+       foldr f z (Deep _ pr m sf) =
+               foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
+
+       foldl _ z Empty = z
+       foldl f z (Single x) = z `f` x
+       foldl f z (Deep _ pr m sf) =
+               foldl f (foldl (foldl f) (foldl f z pr) m) sf
+
+       foldr1 _ Empty = error "foldr1: empty sequence"
+       foldr1 _ (Single x) = x
+       foldr1 f (Deep _ pr m sf) =
+               foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
+
+       foldl1 _ Empty = error "foldl1: empty sequence"
+       foldl1 _ (Single x) = x
+       foldl1 f (Deep _ pr m sf) =
+               foldl f (foldl (foldl f) (foldl1 f pr) m) sf
+
+instance Traversable FingerTree where
+       traverse _ Empty = pure Empty
+       traverse f (Single x) = Single <$> f x
+       traverse f (Deep v pr m sf) =
+               Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
+                       traverse f sf
 
 {-# INLINE deep #-}
 {-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
 
 {-# INLINE deep #-}
 {-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
@@ -232,16 +247,37 @@ data Digit a
        deriving Show
 #endif
 
        deriving Show
 #endif
 
-instance Functor Digit where
-       fmap f (One a) = One (f a)
-       fmap f (Two a b) = Two (f a) (f b)
-       fmap f (Three a b c) = Three (f a) (f b) (f c)
-       fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
+instance Foldable Digit where
+       foldr f z (One a) = a `f` z
+       foldr f z (Two a b) = a `f` (b `f` z)
+       foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
+       foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
+
+       foldl f z (One a) = z `f` a
+       foldl f z (Two a b) = (z `f` a) `f` b
+       foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
+       foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
+
+       foldr1 f (One a) = a
+       foldr1 f (Two a b) = a `f` b
+       foldr1 f (Three a b c) = a `f` (b `f` c)
+       foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
+
+       foldl1 f (One a) = a
+       foldl1 f (Two a b) = a `f` b
+       foldl1 f (Three a b c) = (a `f` b) `f` c
+       foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
+
+instance Traversable Digit where
+       traverse f (One a) = One <$> f a
+       traverse f (Two a b) = Two <$> f a <*> f b
+       traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
+       traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
 
 instance Sized a => Sized (Digit a) where
        {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
        {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
 
 instance Sized a => Sized (Digit a) where
        {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
        {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
-       size xs = foldlDigit (\ i x -> i + size x) 0 xs
+       size xs = foldl (\ i x -> i + size x) 0 xs
 
 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
 
 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
@@ -260,9 +296,16 @@ data Node a
        deriving Show
 #endif
 
        deriving Show
 #endif
 
-instance Functor (Node) where
-       fmap f (Node2 v a b) = Node2 v (f a) (f b)
-       fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
+instance Foldable Node where
+       foldr f z (Node2 _ a b) = a `f` (b `f` z)
+       foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
+
+       foldl f z (Node2 _ a b) = (z `f` a) `f` b
+       foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
+
+instance Traversable Node where
+       traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
+       traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
 
 instance Sized (Node a) where
        size (Node2 v _ _)      = v
 
 instance Sized (Node a) where
        size (Node2 v _ _)      = v
@@ -294,6 +337,13 @@ instance Sized (Elem a) where
 instance Functor Elem where
        fmap f (Elem x) = Elem (f x)
 
 instance Functor Elem where
        fmap f (Elem x) = Elem (f x)
 
+instance Foldable Elem where
+       foldr f z (Elem x) = f x z
+       foldl f z (Elem x) = f z x
+
+instance Traversable Elem where
+       traverse f (Elem x) = Elem <$> f x
+
 #ifdef TESTING
 instance (Show a) => Show (Elem a) where
        showsPrec p (Elem x) = showsPrec p x
 #ifdef TESTING
 instance (Show a) => Show (Elem a) where
        showsPrec p (Elem x) = showsPrec p x
@@ -623,14 +673,21 @@ instance Data a => Data (ViewL a)
 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
 
 instance Functor ViewL where
 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
 
 instance Functor ViewL where
-       fmap _ EmptyL           = EmptyL
-       fmap f (x :< xs)        = f x :< fmap f xs
+       fmap = fmapDefault
+
+instance Foldable ViewL where
+       foldr f z EmptyL = z
+       foldr f z (x :< xs) = f x (foldr f z xs)
 
 
-instance FunctorM ViewL where
-       fmapM _ EmptyL          = return EmptyL
-       fmapM f (x :< xs)       = liftM2 (:<) (f x) (fmapM f xs)
-       fmapM_ _ EmptyL         = return ()
-       fmapM_ f (x :< xs)      = f x >> fmapM_ f xs >> return ()
+       foldl f z EmptyL = z
+       foldl f z (x :< xs) = foldl f (f z x) xs
+
+       foldl1 f EmptyL = error "foldl1: empty view"
+       foldl1 f (x :< xs) = foldl f x xs
+
+instance Traversable ViewL where
+       traverse _ EmptyL       = pure EmptyL
+       traverse f (x :< xs)    = (:<) <$> f x <*> traverse f xs
 
 -- | /O(1)/. Analyse the left end of a sequence.
 viewl          ::  Seq a -> ViewL a
 
 -- | /O(1)/. Analyse the left end of a sequence.
 viewl          ::  Seq a -> ViewL a
@@ -675,14 +732,21 @@ instance Data a => Data (ViewR a)
 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
 
 instance Functor ViewR where
 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
 
 instance Functor ViewR where
-       fmap _ EmptyR           = EmptyR
-       fmap f (xs :> x)        = fmap f xs :> f x
+       fmap = fmapDefault
+
+instance Foldable ViewR where
+       foldr f z EmptyR = z
+       foldr f z (xs :> x) = foldr f (f x z) xs
 
 
-instance FunctorM ViewR where
-       fmapM _ EmptyR          = return EmptyR
-       fmapM f (xs :> x)       = liftM2 (:>) (fmapM f xs) (f x)
-       fmapM_ _ EmptyR         = return ()
-       fmapM_ f (xs :> x)      = fmapM_ f xs >> f x >> return ()
+       foldl f z EmptyR = z
+       foldl f z (xs :> x) = f (foldl f z xs) x
+
+       foldr1 f EmptyR = error "foldr1: empty view"
+       foldr1 f (xs :> x) = foldr f x xs
+
+instance Traversable ViewR where
+       traverse _ EmptyR       = pure EmptyR
+       traverse f (xs :> x)    = (:>) <$> traverse f xs <*> f x
 
 -- | /O(1)/. Analyse the right end of a sequence.
 viewr          ::  Seq a -> ViewR a
 
 -- | /O(1)/. Analyse the right end of a sequence.
 viewr          ::  Seq a -> ViewR a
@@ -934,127 +998,6 @@ splitDigit i (Four a b c d)
 fromList       :: [a] -> Seq a
 fromList       =  Data.List.foldl' (|>) empty
 
 fromList       :: [a] -> Seq a
 fromList       =  Data.List.foldl' (|>) empty
 
--- | /O(n)/. List of elements of the sequence.
-toList         :: Seq a -> [a]
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE toList #-}
-toList xs      =  build (\ c n -> foldr c n xs)
-#else
-toList         =  foldr (:) []
-#endif
-
-------------------------------------------------------------------------
--- Folds
-------------------------------------------------------------------------
-
--- | /O(n*t)/. Fold over the elements of a sequence,
--- associating to the right.
-foldr :: (a -> b -> b) -> b -> Seq a -> b
-foldr f z (Seq xs) = foldrTree f' z xs
-  where f' (Elem x) y = f x y
-
-foldrTree :: (a -> b -> b) -> b -> FingerTree a -> b
-foldrTree _ z Empty = z
-foldrTree f z (Single x) = x `f` z
-foldrTree f z (Deep _ pr m sf) =
-       foldrDigit f (foldrTree (flip (foldrNode f)) (foldrDigit f z sf) m) pr
-
-foldrDigit :: (a -> b -> b) -> b -> Digit a -> b
-foldrDigit f z (One a) = a `f` z
-foldrDigit f z (Two a b) = a `f` (b `f` z)
-foldrDigit f z (Three a b c) = a `f` (b `f` (c `f` z))
-foldrDigit f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
-
-foldrNode :: (a -> b -> b) -> b -> Node a -> b
-foldrNode f z (Node2 _ a b) = a `f` (b `f` z)
-foldrNode f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
-
--- | /O(n*t)/. A variant of 'foldr' that has no base case,
--- and thus may only be applied to non-empty sequences.
-foldr1 :: (a -> a -> a) -> Seq a -> a
-foldr1 f (Seq xs) = getElem (foldr1Tree f' xs)
-  where f' (Elem x) (Elem y) = Elem (f x y)
-
-foldr1Tree :: (a -> a -> a) -> FingerTree a -> a
-foldr1Tree _ Empty = error "foldr1: empty sequence"
-foldr1Tree _ (Single x) = x
-foldr1Tree f (Deep _ pr m sf) =
-       foldrDigit f (foldrTree (flip (foldrNode f)) (foldr1Digit f sf) m) pr
-
-foldr1Digit :: (a -> a -> a) -> Digit a -> a
-foldr1Digit f (One a) = a
-foldr1Digit f (Two a b) = a `f` b
-foldr1Digit f (Three a b c) = a `f` (b `f` c)
-foldr1Digit f (Four a b c d) = a `f` (b `f` (c `f` d))
-
--- | /O(n*t)/. Fold over the elements of a sequence,
--- associating to the left.
-foldl :: (a -> b -> a) -> a -> Seq b -> a
-foldl f z (Seq xs) = foldlTree f' z xs
-  where f' x (Elem y) = f x y
-
-foldlTree :: (a -> b -> a) -> a -> FingerTree b -> a
-foldlTree _ z Empty = z
-foldlTree f z (Single x) = z `f` x
-foldlTree f z (Deep _ pr m sf) =
-       foldlDigit f (foldlTree (foldlNode f) (foldlDigit f z pr) m) sf
-
-foldlDigit :: (a -> b -> a) -> a -> Digit b -> a
-foldlDigit f z (One a) = z `f` a
-foldlDigit f z (Two a b) = (z `f` a) `f` b
-foldlDigit f z (Three a b c) = ((z `f` a) `f` b) `f` c
-foldlDigit f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
-
-foldlNode :: (a -> b -> a) -> a -> Node b -> a
-foldlNode f z (Node2 _ a b) = (z `f` a) `f` b
-foldlNode f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
-
--- | /O(n*t)/. A variant of 'foldl' that has no base case,
--- and thus may only be applied to non-empty sequences.
-foldl1 :: (a -> a -> a) -> Seq a -> a
-foldl1 f (Seq xs) = getElem (foldl1Tree f' xs)
-  where f' (Elem x) (Elem y) = Elem (f x y)
-
-foldl1Tree :: (a -> a -> a) -> FingerTree a -> a
-foldl1Tree _ Empty = error "foldl1: empty sequence"
-foldl1Tree _ (Single x) = x
-foldl1Tree f (Deep _ pr m sf) =
-       foldlDigit f (foldlTree (foldlNode f) (foldl1Digit f pr) m) sf
-
-foldl1Digit :: (a -> a -> a) -> Digit a -> a
-foldl1Digit f (One a) = a
-foldl1Digit f (Two a b) = a `f` b
-foldl1Digit f (Three a b c) = (a `f` b) `f` c
-foldl1Digit f (Four a b c d) = ((a `f` b) `f` c) `f` d
-
-------------------------------------------------------------------------
--- Derived folds
-------------------------------------------------------------------------
-
--- | /O(n*t)/. Fold over the elements of a sequence,
--- associating to the right, but strictly.
-foldr' :: (a -> b -> b) -> b -> Seq a -> b
-foldr' f z xs = foldl f' id xs z
-  where f' k x z = k $! f x z
-
--- | /O(n*t)/. Monadic fold over the elements of a sequence,
--- associating to the right, i.e. from right to left.
-foldrM :: Monad m => (a -> b -> m b) -> b -> Seq a -> m b
-foldrM f z xs = foldl f' return xs z
-  where f' k x z = f x z >>= k
-
--- | /O(n*t)/. Fold over the elements of a sequence,
--- associating to the left, but strictly.
-foldl' :: (a -> b -> a) -> a -> Seq b -> a
-foldl' f z xs = foldr f' id xs z
-  where f' x k z = k $! f z x
-
--- | /O(n*t)/. Monadic fold over the elements of a sequence,
--- associating to the left, i.e. from left to right.
-foldlM :: Monad m => (a -> b -> m a) -> a -> Seq b -> m a
-foldlM f z xs = foldr f' return xs z
-  where f' x k z = f z x >>= k
-
 ------------------------------------------------------------------------
 -- Reverse
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- Reverse
 ------------------------------------------------------------------------
index 9300127..fe3b0b4 100644 (file)
@@ -115,6 +115,7 @@ import Prelude hiding (filter,foldr,null,map)
 import qualified Data.List as List
 import Data.Monoid (Monoid(..))
 import Data.Typeable
 import qualified Data.List as List
 import Data.Monoid (Monoid(..))
 import Data.Typeable
+import Data.Foldable (Foldable(foldMap))
 
 {-
 -- just for testing
 
 {-
 -- just for testing
@@ -152,6 +153,10 @@ instance Ord a => Monoid (Set a) where
     mappend = union
     mconcat = unions
 
     mappend = union
     mconcat = unions
 
+instance Foldable Set where
+    foldMap f Tip = mempty
+    foldMap f (Bin _s k l r) = foldMap f l `mappend` f k `mappend` foldMap f r
+
 #if __GLASGOW_HASKELL__
 
 {--------------------------------------------------------------------
 #if __GLASGOW_HASKELL__
 
 {--------------------------------------------------------------------
diff --git a/Data/Traversable.hs b/Data/Traversable.hs
new file mode 100644 (file)
index 0000000..e133238
--- /dev/null
@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Traversable
+-- Copyright   :  Conor McBride and Ross Paterson 2005
+-- License     :  BSD-style (see the LICENSE file in the distribution)
+--
+-- Maintainer  :  ross@soi.city.ac.uk
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Class of data structures that can be traversed from left to right.
+--
+-- See also <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.
+
+module Data.Traversable (
+       Traversable(..),
+       sequenceA,
+       sequence,
+       fmapDefault,
+       foldMapDefault,
+       ) where
+
+import Prelude hiding (mapM, sequence)
+import qualified Prelude (mapM)
+import Control.Applicative
+import Data.Monoid (Monoid)
+import Data.Array
+
+-- | Functors representing data structures that can be traversed from
+-- left to right.
+--
+-- Minimal complete definition: 'traverse'.
+--
+-- Instances are similar to 'Functor', e.g. given a data type
+--
+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
+--
+-- a suitable instance would be
+--
+-- > instance Traversable Tree
+-- >   traverse f Empty = pure Empty
+-- >   traverse f (Leaf x) = Leaf <$> f x
+-- >   traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r
+--
+-- This is suitable even for abstract types, as the laws for '<*>'
+-- imply a form of associativity.
+--
+class Traversable t where
+       -- | Map each element of a structure to an action, evaluate
+       -- these actions from left to right, and collect the results.
+       traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
+
+       -- | Map each element of a structure to an monadic action, evaluate
+       -- these actions from left to right, and collect the results.
+       mapM :: Monad m => (a -> m b) -> t a -> m (t b)
+       mapM f = unwrapMonad . traverse (WrapMonad . f)
+
+-- instances for Prelude types
+
+instance Traversable Maybe where
+       traverse f Nothing = pure Nothing
+       traverse f (Just x) = Just <$> f x
+
+instance Traversable [] where
+       traverse f = foldr cons_f (pure [])
+         where cons_f x ys = (:) <$> f x <*> ys
+
+       mapM = Prelude.mapM
+
+instance Ix i => Traversable (Array i) where
+       traverse f arr = listArray (bounds arr) <$> traverse f (elems arr)
+
+-- general functions
+
+-- | Evaluate each action in the structure from left to right,
+-- and collect the results.
+sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)
+sequenceA = traverse id
+
+-- | Evaluate each monadic action in the structure from left to right,
+-- and collect the results.
+sequence :: (Traversable t, Monad m) => t (m a) -> m (t a)
+sequence = mapM id
+
+-- | Any 'Traversable' can also be made an instance of 'Functor' by
+-- defining 'fmap' as 'fmapDefault'.
+fmapDefault :: Traversable t => (a -> b) -> t a -> t b
+fmapDefault f = getId . traverse (Id . f)
+
+-- | Any 'Traversable' can also be made an instance of
+-- 'Data.Foldable.Foldable' by defining 'Data.Foldable.foldMap'
+-- as 'foldMapDefault'.
+foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m
+foldMapDefault f = getConst . traverse (Const . f)
+
+-- local instances
+
+newtype Id a = Id { getId :: a }
+
+instance Applicative Id where
+       pure = Id
+       Id f <*> Id x = Id (f x)
index 5a30470..e0a7cb6 100644 (file)
@@ -28,9 +28,13 @@ module Data.Tree(
 import Prelude
 #endif
 
 import Prelude
 #endif
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Control.Monad
-import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList, toList,
+import Data.Monoid (Monoid(..))
+import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,
                        ViewL(..), ViewR(..), viewl, viewr)
                        ViewL(..), ViewR(..), viewl, viewr)
+import Data.Foldable (Foldable(foldMap), toList)
+import Data.Traversable (Traversable(traverse))
 import Data.Typeable
 
 #include "Typeable.h"
 import Data.Typeable
 
 #include "Typeable.h"
@@ -57,6 +61,12 @@ instance Functor Tree where
 mapTree              :: (a -> b) -> (Tree a -> Tree b)
 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
 
 mapTree              :: (a -> b) -> (Tree a -> Tree b)
 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
 
+instance Traversable Tree where
+  traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts
+
+instance Foldable Tree where
+  foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts
+
 -- | Neat 2-dimensional drawing of a tree.
 drawTree :: Tree String -> String
 drawTree  = unlines . draw
 -- | Neat 2-dimensional drawing of a tree.
 drawTree :: Tree String -> String
 drawTree  = unlines . draw
index f691346..c45ccd4 100644 (file)
@@ -9,6 +9,7 @@ description:
        and a large collection of useful libraries ranging from data
        structures to parsing combinators and debugging utilities.
 exposed-modules:
        and a large collection of useful libraries ranging from data
        structures to parsing combinators and debugging utilities.
 exposed-modules:
+       Control.Applicative,
        Control.Arrow,
        Control.Concurrent,
        Control.Concurrent.Chan,
        Control.Arrow,
        Control.Concurrent,
        Control.Concurrent.Chan,
@@ -41,6 +42,7 @@ exposed-modules:
        Data.Dynamic,
        Data.Either,
        Data.Eq,
        Data.Dynamic,
        Data.Either,
        Data.Eq,
+       Data.Foldable,
        Data.FiniteMap,
        Data.FunctorM,
        -- Data.Generics,
        Data.FiniteMap,
        Data.FunctorM,
        -- Data.Generics,
@@ -71,6 +73,7 @@ exposed-modules:
        Data.Sequence,
        Data.Set,
        Data.Tree,
        Data.Sequence,
        Data.Set,
        Data.Tree,
+       Data.Traversable,
        Data.Tuple,
        Data.Typeable,
        Data.Unique,
        Data.Tuple,
        Data.Typeable,
        Data.Unique,
index e10a39a..2c8067e 100644 (file)
@@ -7,6 +7,7 @@ maintainer:     libraries@haskell.org
 exposed:       True
 
 exposed-modules:
 exposed:       True
 
 exposed-modules:
+       Control.Applicative,
        Control.Arrow,
        Control.Concurrent,
        Control.Concurrent.Chan,
        Control.Arrow,
        Control.Concurrent,
        Control.Concurrent.Chan,
@@ -40,6 +41,7 @@ exposed-modules:
        Data.Either,
        Data.Eq,
        Data.FiniteMap,
        Data.Either,
        Data.Eq,
        Data.FiniteMap,
+       Data.Foldable,
        Data.FunctorM,
        Data.Generics,
        Data.Generics.Aliases,
        Data.FunctorM,
        Data.Generics,
        Data.Generics.Aliases,
@@ -68,6 +70,7 @@ exposed-modules:
        Data.STRef.Strict,
        Data.Sequence,
        Data.Set,
        Data.STRef.Strict,
        Data.Sequence,
        Data.Set,
+       Data.Traversable,
        Data.Tree,
        Data.Tuple,
        Data.Typeable,
        Data.Tree,
        Data.Tuple,
        Data.Typeable,