{-# OPTIONS_GHC -fno-warn-orphans #-}
module Control.Monad.Utils where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import qualified Control.Monad.Trans.State as S

unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
unless b fa = if b then pure mempty else fa
{-# INLINABLE unless #-}

when :: (Applicative f, Monoid a) => Bool -> f a -> f a
when b fa = if b then fa else pure mempty
{-# INLINABLE when #-}

-- * Type 'ComposeState'
-- | Composing state and a monad not affecting the state.
type ComposeState st = Compose (S.State st)
instance Semigroup (ComposeState st Maybe a) where
	(<>) = (>>)
instance Monoid (ComposeState st Maybe ()) where
	mempty  = pure ()
	mappend = (<>)
instance Monad (ComposeState st Maybe) where
	return = pure
	Compose sma >>= a2csmb =
		Compose $ sma >>= \ma ->
			maybe (return Nothing) getCompose $
			ma >>= Just . a2csmb
{- NOTE: the 'st' may need to use the 'String', so no such instance.
instance Monad m => IsString (ComposeState st m ()) where
	fromString = Compose . return . fromString
-}

-- | Lift a function over 'm' to a 'ComposeState' one.
($$) :: (m a -> m a) -> ComposeState st m a -> ComposeState st m a
($$) f m = Compose $ f <$> getCompose m
infixr 0 $$

liftComposeState :: Monad m => S.State st a -> ComposeState st m a
liftComposeState = Compose . (return <$>)

runComposeState :: st -> ComposeState st m a -> (m a, st)
runComposeState st = (`S.runState` st) . getCompose

evalComposeState :: st -> ComposeState st m a -> m a
evalComposeState st = (`S.evalState` st) . getCompose

-- * Folding
-- | Lazy in the monoidal accumulator.
foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)

-- | Strict in the monoidal accumulator.
-- For monads strict in the left argument of bind ('>>='),
-- this will run in constant space.
foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
foldlMapM f xs = foldr go pure xs mempty
	where
	-- go :: a -> (b -> m b) -> b -> m b
	go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b