{-# 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'
, Ap(..)
) where
import Prelude hiding (foldr,foldl)
import Control.Applicative (Alternative, Applicative(..), liftA2)
import Control.Monad (MonadPlus, ap, liftM, liftM2)
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans.Cont (ContT(..), cont)
import Data.Foldable
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (runIdentity)
import Data.Monoid hiding ((<>))
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup
#endif
import Data.Traversable (traverse,Traversable)
import GHC.Generics (Generic,Generic1)
newtype Ap f a = Ap { getAp :: f a }
deriving ( Alternative, Applicative
, Enum, Eq, Foldable, Functor
, Generic
#if MIN_VERSION_base(4,6,0)
, Generic1
#endif
, Monad
#if MIN_VERSION_base(4,9,0)
, MonadFail
#endif
, MonadFix, MonadPlus
, Num, Ord, Read, Show, Traversable
)
#if MIN_VERSION_base(4,9,0)
instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
(Ap x) <> (Ap y) = Ap $ liftA2 (<>) x y
#endif
instance (Applicative f, Monoid a) => Monoid (Ap f a) where
mempty = Ap $ pure mempty
#if !(MIN_VERSION_base(4,11,0))
mappend (Ap x) (Ap y) = Ap $ liftA2 (mappend) x y
#endif
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