]> Git — Sourcephile - doclang.git/blob - src/Control/Monad/Utils.hs
Fix megaparsec-8 update
[doclang.git] / 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