Control/Monad/Utils.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Control.Monad.Utils where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Control.Monad (Monad(..))
   6 import Data.Bool
   7 import Data.Foldable (Foldable(..))
   8 import Data.Function (($), (.))
   9 import Data.Functor ((<$>))
  10 import Data.Functor.Compose (Compose(..))
  11 import Data.Maybe (Maybe(..), maybe)
  12 import Data.Monoid (Monoid(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import qualified Control.Monad.Trans.State as S
  15
  16 unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
  17 unless b fa = if b then pure mempty else fa
  18 {-# INLINABLE unless #-}
  19
  20 when :: (Applicative f, Monoid a) => Bool -> f a -> f a
  21 when b fa = if b then fa else pure mempty
  22 {-# INLINABLE when #-}
  23
  24 -- * Type 'ComposeState'
  25 -- | Composing state and a monad not affecting the state.
  26 type ComposeState st = Compose (S.State st)
  27 instance Semigroup (ComposeState st Maybe a) where
  28         (<>) = (>>)
  29 instance Monoid (ComposeState st Maybe ()) where
  30         mempty  = pure ()
  31         mappend = (<>)
  32 instance Monad (ComposeState st Maybe) where
  33         return = pure
  34         Compose sma >>= a2csmb =
  35                 Compose $ sma >>= \ma ->
  36                         maybe (return Nothing) getCompose $
  37                         ma >>= Just . a2csmb
  38 {- NOTE: the 'st' may need to use the 'String', so no such instance.
  39 instance Monad m => IsString (ComposeState st m ()) where
  40         fromString = Compose . return . fromString
  41 -}
  42
  43 -- | Lift a function over 'm' to a 'ComposeState' one.
  44 ($$) :: (m a -> m a) -> ComposeState st m a -> ComposeState st m a
  45 ($$) f m = Compose $ f <$> getCompose m
  46 infixr 0 $$
  47
  48 liftComposeState :: Monad m => S.State st a -> ComposeState st m a
  49 liftComposeState = Compose . (return <$>)
  50
  51 runComposeState :: st -> ComposeState st m a -> (m a, st)
  52 runComposeState st = (`S.runState` st) . getCompose
  53
  54 evalComposeState :: st -> ComposeState st m a -> m a
  55 evalComposeState st = (`S.evalState` st) . getCompose
  56
  57 -- * Folding
  58 -- | Lazy in the monoidal accumulator.
  59 foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
  60 foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)
  61
  62 -- | Strict in the monoidal accumulator.
  63 -- For monads strict in the left argument of bind ('>>='),
  64 -- this will run in constant space.
  65 foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
  66 foldlMapM f xs = foldr go pure xs mempty
  67         where
  68         -- go :: a -> (b -> m b) -> b -> m b
  69         go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b
  70