Multiplicative.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Monoid.Multiplicative
-- Copyright   :  (c) Edward Kmett 2009
-- License     :  BSD-style
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  portable (but instances use MPTCs)
--
-- When dealing with a 'Ring' or other structure, you often need a pair of 
-- 'Monoid' instances that are closely related. Making a @newtype@ for one
-- is unsatisfying and yields an unnatural programming style. 
--
-- A 'Multiplicative' is a 'Monoid' that is intended for use in a scenario
-- that can be extended to have another 'Monoid' slot in for addition. This
-- enables one to use common notation.
--
-- Any 'Multiplicative' can be turned into a 'Monoid' using the 'Log' wrapper.
--
-- Any 'Monoid' can be turned into a 'Multiplicative' using the 'Exp' wrapper.
--
-- Instances are supplied for common Monads of Monoids, in a fashion 
-- which can be extended if the 'Monad' is a 'MonadPlus' to yield a 'RightSemiNearRing'
--
-- Instances are also supplied for common Applicatives of Monoids, in a
-- fashion which can be extended if the 'Applicative' is 'Alternative' to
-- yield a 'RightSemiNearRing'
-----------------------------------------------------------------------------

module Data.Monoid.Multiplicative 
    ( module Data.Monoid.Additive
    -- * Multiplicative Monoids
    , Multiplicative
    , one, times
    -- * Multiplicative to Monoid
    , Log(Log, getLog)
    -- * Monoid to Multiplicative
    , Exp(Exp, getExp)
    ) where

import Control.Applicative

import Control.Concurrent.STM

import Control.Monad.Cont
import Control.Monad.Identity

import Control.Monad.Reader

import qualified Control.Monad.RWS.Lazy as LRWS
import qualified Control.Monad.RWS.Strict as SRWS

import qualified Control.Monad.State.Lazy as LState
import qualified Control.Monad.State.Strict as SState

import qualified Control.Monad.Writer.Lazy as LWriter
import qualified Control.Monad.Writer.Strict as SWriter

import qualified Control.Monad.ST.Lazy as LST
import qualified Control.Monad.ST.Strict as SST

import Data.FingerTree

import Data.Monoid.Additive
import Data.Monoid.FromString
import Data.Generator
import Data.Monoid.Instances ()
import Data.Monoid.Self

import Data.Ratio

import qualified Data.Sequence as Seq
import Data.Sequence (Seq)

import Text.Parsec.Prim

class Multiplicative m where
    one :: m
    times :: m -> m -> m

instance Multiplicative m => Multiplicative (Dual m) where
    one = Dual one
    Dual x `times` Dual y = Dual (y `times` x)

instance Multiplicative m => Multiplicative (m `ReducedBy` s) where
    one = Reduction one
    Reduction x `times` Reduction y = Reduction (x `times` y)

-- | Convert a 'Multiplicative' into a 'Monoid'. Mnemonic: @Log a + Log b = Log (a * b)@
data Log m = Log { getLog :: m }

instance Multiplicative m => Monoid (Log m) where
    mempty = Log one
    Log a `mappend` Log b = Log (a `times` b)

-- | Convert a 'Monoid' into a 'Multiplicative'. Mnemonic: @Exp a * Exp b = Exp (a + b)@
data Exp m = Exp { getExp :: m }

instance Monoid m => Multiplicative (Exp m) where
    one = Exp mempty
    Exp a `times` Exp b = Exp (a `mappend` b)

-- simple monoid transformer instances
instance Multiplicative m => Multiplicative (Self m) where
    one = Self one  
    Self a `times` Self b = Self (a `times` b)

instance Multiplicative m => Multiplicative (FromString m) where
    one = FromString one
    FromString a `times` FromString b = FromString (a `times` b)

-- the goal of this is that I can make left seminearrings out of any 'Alternative' wrapped around a monoid
-- in particular its useful for containers

instance Monoid m => Multiplicative [m] where
    one = return mempty
    times = liftM2 mappend

instance Monoid m => Multiplicative (Seq m) where
    one = return mempty
    times = liftM2 mappend

-- and things that can't quite be a Monad in Haskell
instance (Measured v m, Monoid m) => Multiplicative (FingerTree v m) where
    one = singleton mempty
    xss `times` yss = getSelf $ mapReduce (flip fmap' yss . mappend) xss

-- but it can at least serve as a canonical multiplication for any monad. 
instance Monoid m => Multiplicative (Maybe m) where
    one = return mempty
    times = liftM2 mappend

instance Monoid m => Multiplicative (Identity m) where
    one = return mempty
    times = liftM2 mappend

instance (Monoid m) => Multiplicative (Cont r m) where
    one = return mempty
    times = liftM2 mappend

instance (Monoid w, Monoid m) => Multiplicative (SRWS.RWS r w s m) where
    one = return mempty
    times = liftM2 mappend

instance (Monoid w, Monoid m) => Multiplicative (LRWS.RWS r w s m) where
    one = return mempty
    times = liftM2 mappend

instance Monoid m => Multiplicative (SState.State s m) where
    one = return mempty
    times = liftM2 mappend

instance Monoid m => Multiplicative (LState.State s m) where
    one = return mempty
    times = liftM2 mappend

instance Monoid m => Multiplicative (Reader e m) where
    one = return mempty
    times = liftM2 mappend

instance (Monoid w, Monoid m) => Multiplicative (SWriter.Writer w m) where
    one = return mempty
    times = liftM2 mappend

instance (Monoid w, Monoid m) => Multiplicative (LWriter.Writer w m) where
    one = return mempty
    times = liftM2 mappend

instance (Monad m, Monoid n) => Multiplicative (ContT r m n) where
    one = return mempty 
    times = liftM2 mappend

instance (Monad m, Monoid w, Monoid n) => Multiplicative (SRWS.RWST r w s m n) where 
    one = return mempty 
    times = liftM2 mappend

instance (Monad m, Monoid w, Monoid n) => Multiplicative (LRWS.RWST r w s m n) where 
    one = return mempty 
    times = liftM2 mappend

instance (Monad m, Monoid n) => Multiplicative (SState.StateT s m n) where
    one = return mempty
    times = liftM2 mappend

instance (Monad m, Monoid n) => Multiplicative (LState.StateT s m n) where
    one = return mempty
    times = liftM2 mappend

instance (Monad m, Monoid n) => Multiplicative (ReaderT e m n) where
    one = return mempty
    times = liftM2 mappend

instance (Monad m, Monoid w, Monoid n) => Multiplicative (SWriter.WriterT w m n) where
    one = return mempty 
    times = liftM2 mappend

instance (Monad m, Monoid w, Monoid n) => Multiplicative (LWriter.WriterT w m n) where
    one = return mempty 
    times = liftM2 mappend

instance Monoid n => Multiplicative (IO n) where
    one = return mempty
    times = liftM2 mappend

instance Monoid n => Multiplicative (SST.ST s n) where
    one = return mempty
    times = liftM2 mappend

instance Monoid n => Multiplicative (LST.ST s n) where
    one = return mempty
    times = liftM2 mappend

instance Monoid n => Multiplicative (STM n) where
    one = return mempty
    times = liftM2 mappend

instance (Stream s m t, Monoid n) => Multiplicative (ParsecT s u m n) where
    one = return mempty
    times = liftM2 mappend

-- Applicative instances

instance Monoid n => Multiplicative (ZipList n) where
    one = pure mempty
    times = liftA2 mappend

instance Monoid m => Multiplicative (Const m a) where
    one = pure undefined
    times = liftA2 undefined

-- Numeric instances
instance Multiplicative Int where
    one = 1
    times = (*)

instance Multiplicative Integer where
    one = 1
    times = (*)

instance Integral m => Multiplicative (Ratio m) where
    one = 1
    times = (*)