Control/Monad/Utils.hs

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