src/Control/Monad/Utils.hs

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