Monad.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts, TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Monoid.Applicative
-- Copyright   :  (c) Edward Kmett 2009
-- License     :  BSD-style
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (MPTCs)
--
-- 'Monoid' instances for working with a 'Monad'
--
-----------------------------------------------------------------------------

module Data.Monoid.Monad 
    ( module Data.Monoid.Reducer
    , module Data.Ring.Semi.Near
    -- * Actions
    , Action(Action,getAction)
    , snocAction
    -- * Lifting Modules
    , ActionWith(ActionWith,getActionWith)
    -- * Wrapped Monads
    , WrappedMonad(WrappedMonad, getWrappedMonad)
    ) where

import Control.Functor.Pointed
import Data.Monoid.Reducer
import Data.Ring.Semi.Near
import Data.Ring.Module
import Control.Monad

-- | An 'Action' uses glues together 'Monad' actions with (>>)
--   in the manner of 'mapM_' from "Data.Foldable". Any values returned by 
--   reduced actions are discarded.
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 #-} 

-- | Efficiently avoid needlessly rebinding when using 'snoc' on an action that already returns ()
--   A rewrite rule automatically applies this when possible
snocAction :: Reducer (m ()) (Action m) => Action m -> m () -> Action m
snocAction a = mappend a . Action

-- | A 'WrappedMonad' turns any 'MonadPlus' instance into a 'Monoid'.
--   It also provides a 'Multiplicative' instance for a 'Monad' wrapped around a 'Monoid'
--   and asserts that any 'MonadPlus' applied to a 'Monoid' forms a 'LeftSemiNearRing' 
--   under these operations.

newtype WrappedMonad m a = WrappedMonad { getWrappedMonad :: m a } 
    deriving (Eq,Ord,Show,Read,Functor,Pointed, Monad,MonadPlus)

instance (Monad m, Monoid a) => Multiplicative (WrappedMonad m a) where
    one = WrappedMonad (return mempty)
    WrappedMonad m `times` WrappedMonad n = WrappedMonad (liftM2 mappend m n)
    
instance (MonadPlus m) => Monoid (WrappedMonad m a) where
    mempty = mzero
    mappend = mplus

instance (MonadPlus m, c `Reducer` a) => Reducer c (WrappedMonad m a) where
    unit = WrappedMonad . return . unit

instance (MonadPlus m, Monoid a) => LeftSemiNearRing (WrappedMonad m a)

-- | if @m@ is a 'Module' over @r@ and @f@ is a 'Monad' then @f `ActionWith` m@ is a 'Module' as well

newtype ActionWith f m = ActionWith { getActionWith :: f m } 
    deriving (Eq,Ord,Show,Read,Functor,Pointed, Monad,MonadPlus)

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

instance (Group m, Monad f) => Group (f `ActionWith` m) where
    gnegate = liftM gnegate
    minus = liftM2 minus
    gsubtract = liftM2 gsubtract

instance (c `Reducer` m, Monad f) => Reducer c (f `ActionWith` m) where
    unit = return . unit

instance (LeftModule r m, Monad f) => LeftModule r (f `ActionWith` m) where
    x *. m = liftM (x *.) m

instance (RightModule r m, Monad f) => RightModule r (f `ActionWith` m) where
    m .* y = liftM (.* y) m

instance (Module r m, Monad f) => Module r (f `ActionWith` m)