{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Constrictor
(
(<$!>)
, fmap'
, liftM'
, liftM2'
, liftM3'
, liftM4'
, liftM5'
, ap'
, traverse'
, traverse''
, mapM'
, foldrMap
, foldlMap
, foldrMap'
, foldlMap'
, foldlMapA
, foldrMapA
, foldlMapM'
, foldrMapM'
) where
import Prelude hiding (foldr,foldl)
import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (ap, liftM)
import Control.Monad.Trans.Cont (ContT(..), cont)
import Data.Foldable
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (runIdentity)
import Data.Monoid (Monoid(mappend,mempty))
import Data.Traversable (traverse,Traversable)
foldlMapA :: forall t b a f. (Foldable t, Monoid b, Applicative f) => (a -> f b) -> t a -> f b
foldlMapA f = foldr (\x y -> liftA2 mappend (f x) y) (pure mempty)
foldrMapA :: forall t b a f. (Foldable t, Monoid b, Applicative f) => (a -> f b) -> t a -> f b
foldrMapA f = foldl (\y x -> liftA2 (flip mappend) (f x) y) (pure mempty)
foldlMapM' :: forall t b a m. (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
foldlMapM' f xs = foldr f' return xs mempty
where
f' :: a -> (b -> m b) -> b -> m b
f' x k bl = do
!br <- f x
k $! (mappend bl br)
foldrMapM' :: forall t b a m. (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
foldrMapM' f xs = foldl f' return xs mempty
where
f' :: (b -> m b) -> a -> b -> m b
f' k x br = do
!bl <- f x
k $! (mappend bl br)
infixl 4 <$!>, `fmap'`, `liftM'`
(<$!>) :: Monad m => (a -> b) -> m a -> m b
{-# INLINE (<$!>) #-}
f <$!> m = do
!x <- m
return $! f x
fmap' :: Monad m => (a -> b) -> m a -> m b
{-# INLINE fmap' #-}
fmap' = (<$!>)
liftM' :: Monad m => (a -> b) -> m a -> m b
{-# INLINE liftM' #-}
liftM' = (<$!>)
liftM2' :: Monad m => (a -> b -> c) -> m a -> m b -> m c
{-# INLINE liftM2' #-}
liftM2' f a b = do
!x <- a
!y <- b
return $! f x y
liftM3' :: Monad m => (a -> b -> c -> d) -> m a -> m b -> m c -> m d
{-# INLINE liftM3' #-}
liftM3' f a b c = do
!x <- a
!y <- b
!z <- c
return $! f x y z
liftM4' :: Monad m => (a -> b -> c -> d -> e) -> m a -> m b -> m c -> m d -> m e
{-# INLINE liftM4' #-}
liftM4' f a b c d = do
!x <- a
!y <- b
!z <- c
!u <- d
return $! f x y z u
liftM5' :: Monad m => (a -> b -> c -> d -> e -> f) -> m a -> m b -> m c -> m d -> m e -> m f
{-# INLINE liftM5' #-}
liftM5' f a b c d e = do
!x <- a
!y <- b
!z <- c
!u <- d
!v <- e
return $! f x y z u v
ap' :: Monad m => m (a -> b) -> m a -> m b
{-# INLINE ap' #-}
ap' m1 m2 = do
!f <- m1
!x <- m2
return $! f x
#if !(MIN_VERSION_base(4,8,0))
newtype WrappedMonad m a = WrappedMonad { unwrapMonad :: m a }
deriving (Monad)
instance Monad m => Functor (WrappedMonad m) where
fmap f (WrappedMonad v) = WrappedMonad (liftM f v)
instance Monad m => Applicative (WrappedMonad m) where
pure = WrappedMonad . return
WrappedMonad f <*> WrappedMonad v = WrappedMonad (f `ap` v)
#endif
traverse' :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
{-# INLINE traverse' #-}
traverse' f = fmap (runIdentity . evalContT) . getCompose . traverse (Compose . fmap (\a -> cont $ \k -> k $! a) . f)
traverse'' :: (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b)
{-# INLINE traverse'' #-}
#if MIN_VERSION_base(4,8,0)
traverse'' f = fmap' (runIdentity . evalContT) . getCompose . traverse (Compose . fmap' (\a -> cont $ \k -> k $! a) . f)
#else
traverse'' f = unwrapMonad . fmap' (runIdentity . evalContT) . getCompose . traverse (Compose . fmap' (\a -> cont $ \k -> k $! a) . (\x -> WrappedMonad (f x)))
#endif
evalContT :: (Monad m) => ContT r m r -> m r
evalContT m = runContT m return
{-# INLINE evalContT #-}
mapM' :: (Traversable t, Monad m) => (a -> m b) -> t a-> m (t b)
{-# INLINE mapM' #-}
#if MIN_VERSION_base(4,8,0)
mapM' = traverse'
#else
mapM' f xs = unwrapMonad (traverse' (\x -> WrappedMonad (f x)) xs)
#endif
{-# INLINE foldrMap #-}
{-# INLINE foldrMap' #-}
{-# INLINE foldlMap #-}
{-# INLINE foldlMap' #-}
foldlMap :: (Monoid m, Foldable t) => (a -> m) -> t a -> m
foldlMap f = foldl (flip (mappend . f)) mempty
foldrMap :: (Monoid m, Foldable t) => (a -> m) -> t a -> m
foldrMap f = foldr (mappend . f) mempty
foldlMap' :: (Monoid m, Foldable t) => (a -> m) -> t a -> m
foldlMap' f = foldl' (flip (mappend . f)) mempty
foldrMap' :: (Monoid m, Foldable t) => (a -> m) -> t a -> m
foldrMap' f = foldr' (mappend . f) mempty