From 641f8d5964b2b02f4cd7b9081adf6596c6f4d4d7 Mon Sep 17 00:00:00 2001 From: ross Date: Tue, 29 Nov 2005 14:31:59 +0000 Subject: [PATCH] [project @ 2005-11-29 14:31:59 by ross] 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 | 151 +++++++++++++++++++++++++ Data/Foldable.hs | 257 ++++++++++++++++++++++++++++++++++++++++++ Data/IntMap.hs | 6 + Data/Map.hs | 13 +++ Data/Sequence.hs | 293 +++++++++++++++++++----------------------------- Data/Set.hs | 5 + Data/Traversable.hs | 102 +++++++++++++++++ Data/Tree.hs | 12 +- base.cabal | 3 + package.conf.in | 3 + 10 files changed, 669 insertions(+), 176 deletions(-) create mode 100644 Control/Applicative.hs create mode 100644 Data/Foldable.hs create mode 100644 Data/Traversable.hs diff --git a/Control/Applicative.hs b/Control/Applicative.hs new file mode 100644 index 0000000..a395314 --- /dev/null +++ b/Control/Applicative.hs @@ -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 +-- . +-- +-- This interface was introduced for parsers by Niklas Rö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 index 0000000..fcba159 --- /dev/null +++ b/Data/Foldable.hs @@ -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 []) diff --git a/Data/IntMap.hs b/Data/IntMap.hs index e210442..1be0bbe 100644 --- a/Data/IntMap.hs +++ b/Data/IntMap.hs @@ -138,6 +138,7 @@ import Data.Int import qualified Data.IntSet as IntSet import Data.Monoid (Monoid(..)) import Data.Typeable +import Data.Foldable (Foldable(foldMap)) {- -- just for testing @@ -216,6 +217,11 @@ instance Ord a => Monoid (IntMap a) where 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__ {-------------------------------------------------------------------- diff --git a/Data/Map.hs b/Data/Map.hs index f0b7f6f..da12f9d 100644 --- a/Data/Map.hs +++ b/Data/Map.hs @@ -152,6 +152,9 @@ import qualified Data.Set as Set 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 @@ -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 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 --------------------------------------------------------------------} diff --git a/Data/Sequence.hs b/Data/Sequence.hs index c68a6ad..d072a28 100644 --- a/Data/Sequence.hs +++ b/Data/Sequence.hs @@ -39,6 +39,7 @@ module Data.Sequence ( (<|), -- :: 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 @@ -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) - -- * 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 @@ -80,13 +67,14 @@ import Prelude hiding ( 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.FunctorM +import Data.Foldable +import Data.Traversable 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(..), @@ -112,7 +100,20 @@ class Sized a 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 @@ -123,14 +124,6 @@ instance MonadPlus Seq where 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 @@ -209,11 +202,33 @@ instance Sized a => Sized (FingerTree a) where 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) #-} @@ -232,16 +247,37 @@ data Digit a 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)) #-} - 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) #-} @@ -260,9 +296,16 @@ data Node a 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 @@ -294,6 +337,13 @@ instance Sized (Elem a) where 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 @@ -623,14 +673,21 @@ instance Data a => Data (ViewL a) 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 @@ -675,14 +732,21 @@ instance Data a => Data (ViewR a) 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 @@ -934,127 +998,6 @@ splitDigit i (Four a b c d) 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 ------------------------------------------------------------------------ diff --git a/Data/Set.hs b/Data/Set.hs index 9300127..fe3b0b4 100644 --- a/Data/Set.hs +++ b/Data/Set.hs @@ -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 Data.Foldable (Foldable(foldMap)) {- -- just for testing @@ -152,6 +153,10 @@ instance Ord a => Monoid (Set a) where 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__ {-------------------------------------------------------------------- diff --git a/Data/Traversable.hs b/Data/Traversable.hs new file mode 100644 index 0000000..e133238 --- /dev/null +++ b/Data/Traversable.hs @@ -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 . + +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) diff --git a/Data/Tree.hs b/Data/Tree.hs index 5a30470..e0a7cb6 100644 --- a/Data/Tree.hs +++ b/Data/Tree.hs @@ -28,9 +28,13 @@ module Data.Tree( import Prelude #endif +import Control.Applicative (Applicative(..)) 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) +import Data.Foldable (Foldable(foldMap), toList) +import Data.Traversable (Traversable(traverse)) 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) +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 diff --git a/base.cabal b/base.cabal index f691346..c45ccd4 100644 --- a/base.cabal +++ b/base.cabal @@ -9,6 +9,7 @@ description: 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, @@ -41,6 +42,7 @@ exposed-modules: Data.Dynamic, Data.Either, Data.Eq, + Data.Foldable, Data.FiniteMap, Data.FunctorM, -- Data.Generics, @@ -71,6 +73,7 @@ exposed-modules: Data.Sequence, Data.Set, Data.Tree, + Data.Traversable, Data.Tuple, Data.Typeable, Data.Unique, diff --git a/package.conf.in b/package.conf.in index e10a39a..2c8067e 100644 --- a/package.conf.in +++ b/package.conf.in @@ -7,6 +7,7 @@ maintainer: libraries@haskell.org exposed: True exposed-modules: + Control.Applicative, Control.Arrow, Control.Concurrent, Control.Concurrent.Chan, @@ -40,6 +41,7 @@ exposed-modules: Data.Either, Data.Eq, Data.FiniteMap, + Data.Foldable, Data.FunctorM, Data.Generics, Data.Generics.Aliases, @@ -68,6 +70,7 @@ exposed-modules: Data.STRef.Strict, Data.Sequence, Data.Set, + Data.Traversable, Data.Tree, Data.Tuple, Data.Typeable, -- 1.7.10.4