{-# LANGUAGE Trustworthy #-}
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)
import Data.Proxy
import GHC.Arr
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
{-# INLINE traverse #-}
traverse f = Prelude.foldr cons_f (pure [])
where cons_f x ys = (:) <$> f x <*> ys
mapM = Prelude.mapM
instance Traversable (Either a) where
traverse _ (Left x) = pure (Left x)
traverse f (Right y) = Right <$> f y
instance Traversable ((,) a) where
traverse f (x, y) = (,) x <$> f y
instance Ix i => Traversable (Array i) where
traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)
instance Traversable Proxy where
traverse _ _ = pure Proxy
{-# INLINE traverse #-}
sequenceA _ = pure Proxy
{-# INLINE sequenceA #-}
mapM _ _ = return Proxy
{-# INLINE mapM #-}
sequence _ = return Proxy
{-# INLINE sequence #-}
instance Traversable (Const m) where
traverse _ (Const m) = pure $ Const m
for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)
{-# INLINE for #-}
for = flip traverse
forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)
{-# INLINE forM #-}
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
{-# INLINE fmapDefault #-}
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)