{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts #-}
module Data.Monoid.Monad 
    ( module Control.Monad
    , module Data.Monoid.Reducer
    , Action(Action,getAction)
    , MonadSum(MonadSum,getMonadSum)
    , ActionWith(ActionWith,getActionWith)
    ) where

import Data.Monoid.Reducer
import Control.Monad (MonadPlus, mplus, mzero, (>=>), liftM2)

newtype Action m = Action { getAction :: m () } 

instance Monad m => Monoid (Action m) where
    mempty = Action (return ())
    Action a `mappend` Action b = Action (a >> b)

instance Monad m => Reducer (m a) (Action m) where
    unit a = Action (a >> return ())
    a `cons` Action b = Action (a >> b)
    Action a `snoc` b = Action (a >> b >> return ())

{-# RULES "unitAction" unit = Action #-}
{-# RULES "snocAction" snoc = snocAction #-} 
snocAction :: Reducer (m ()) (Action m) => Action m -> m () -> Action m
snocAction a = mappend a . Action

newtype MonadSum m a = MonadSum { getMonadSum :: m a } 
    deriving (Eq,Ord,Show,Read,Functor,Monad,MonadPlus)

instance MonadPlus m => Monoid (MonadSum m a) where
    mempty = MonadSum mzero
    MonadSum a `mappend` MonadSum b = MonadSum (a `mplus` b)

instance MonadPlus m => Reducer (m a) (MonadSum m a) where
    unit = MonadSum

newtype ActionWith m n = ActionWith { getActionWith :: m n }

instance (Monad m, Monoid n) => Monoid (ActionWith m n) where
    mempty = ActionWith (return mempty)
    ActionWith a `mappend` ActionWith b = ActionWith (liftM2 mappend a b)

instance (Monad m, Monoid n) => Reducer (m n) (ActionWith m n) where
    unit = ActionWith