--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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ö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
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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 [])
import qualified Data.IntSet as IntSet
import Data.Monoid (Monoid(..))
import Data.Typeable
+import Data.Foldable (Foldable(foldMap))
{-
-- just for testing
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__
{--------------------------------------------------------------------
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
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
--------------------------------------------------------------------}
(<|), -- :: 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
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
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(..),
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
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
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) #-}
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) #-}
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 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
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
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
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
------------------------------------------------------------------------
import qualified Data.List as List
import Data.Monoid (Monoid(..))
import Data.Typeable
+import Data.Foldable (Foldable(foldMap))
{-
-- just for testing
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__
{--------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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)
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"
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
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,
Data.Dynamic,
Data.Either,
Data.Eq,
+ Data.Foldable,
Data.FiniteMap,
Data.FunctorM,
-- Data.Generics,
Data.Sequence,
Data.Set,
Data.Tree,
+ Data.Traversable,
Data.Tuple,
Data.Typeable,
Data.Unique,
exposed: True
exposed-modules:
+ Control.Applicative,
Control.Arrow,
Control.Concurrent,
Control.Concurrent.Chan,
Data.Either,
Data.Eq,
Data.FiniteMap,
+ Data.Foldable,
Data.FunctorM,
Data.Generics,
Data.Generics.Aliases,
Data.STRef.Strict,
Data.Sequence,
Data.Set,
+ Data.Traversable,
Data.Tree,
Data.Tuple,
Data.Typeable,
projects / haskell-directory.git / commitdiff