Data/Traversable.hs (original) (raw)

module Data.Traversable ( Traversable(..), for, forM, mapAccumL, mapAccumR, fmapDefault, foldMapDefault, ) where

import Prelude hiding (mapM, sequence, foldr) import qualified Prelude (mapM, foldr) import Control.Applicative import Data.Foldable (Foldable()) import Data.Monoid (Monoid)

#if defined(GLASGOW_HASKELL) import GHC.Arr #elif defined(HUGS) import Hugs.Array #elif defined(NHC) import Array #endif

class (Functor t, Foldable t) => Traversable t where

traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
traverse f = sequenceA . fmap f


sequenceA :: Applicative f => t (f a) -> f (t a)
sequenceA = traverse id


mapM :: Monad m => (a -> m b) -> t a -> m (t b)
mapM f = unwrapMonad . traverse (WrapMonad . f)


sequence :: Monad m => t (m a) -> m (t a)
sequence = mapM id

instance Traversable Maybe where traverse _ Nothing = pure Nothing traverse f (Just x) = Just <$> f x

instance Traversable [] where

traverse f = Prelude.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) fmap traverse f (elems arr)

for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)

for = flip traverse

forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)

forM = flip mapM

newtype StateL s a = StateL { runStateL :: s -> (s, a) }

instance Functor (StateL s) where fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v)

instance Applicative (StateL s) where pure x = StateL (\ s -> (s, x)) StateL kf <*> StateL kv = StateL $ \ s -> let (s', f) = kf s (s'', v) = kv s' in (s'', f v)

mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s

newtype StateR s a = StateR { runStateR :: s -> (s, a) }

instance Functor (StateR s) where fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v)

instance Applicative (StateR s) where pure x = StateR (\ s -> (s, x)) StateR kf <*> StateR kv = StateR $ \ s -> let (s', v) = kv s (s'', f) = kf s' in (s'', f v)

mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s

fmapDefault :: Traversable t => (a -> b) -> t a -> t b

fmapDefault f = getId . traverse (Id . f)

foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m foldMapDefault f = getConst . traverse (Const . f)

newtype Id a = Id { getId :: a }

instance Functor Id where fmap f (Id x) = Id (f x)

instance Applicative Id where pure = Id Id f <*> Id x = Id (f x)