Applicative.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)
--
-- Monoids for working with an 'Applicative' 'Functor'.
--
-----------------------------------------------------------------------------

module Data.Monoid.Applicative 
    ( module Data.Monoid.Reducer
    , module Data.Ring.Semi.Near
    , module Data.Ring.Module
    , Traversal(Traversal,getTraversal)
    , WrappedApplicative(WrappedApplicative,getWrappedApplicative)
    , TraversalWith(TraversalWith,getTraversalWith)
    , snocTraversal
    ) where

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

-- | A 'Traversal' uses an glues together 'Applicative' actions with (*>)
--   in the manner of 'traverse_' from "Data.Foldable". Any values returned by 
--   reduced actions are discarded.
newtype Traversal f = Traversal { getTraversal :: f () } 

instance Applicative f => Monoid (Traversal f) where
    mempty = Traversal (pure ())
    Traversal a `mappend` Traversal b = Traversal (a *> b)

instance Applicative f => Reducer (f a) (Traversal f) where
    unit a = Traversal (a *> pure ())
    a `cons` Traversal b = Traversal (a *> b)
    Traversal a `snoc` b = Traversal (a *> b *> pure ())

{-# RULES "unitTraversal" unit = Traversal #-}
{-# RULES "snocTraversal" snoc = snocTraversal #-}

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


-- | A 'WrappedApplicative' turns any 'Alternative' instance into a 'Monoid'.
--   It also provides a 'Multiplicative' instance for an 'Applicative' functor wrapped around a 'Monoid'
--   and asserts that any 'Alternative' applied to a 'Monoid' forms a 'LeftSemiNearRing' 
--   under these operations.

newtype WrappedApplicative f a = WrappedApplicative { getWrappedApplicative :: f a } 
    deriving (Eq,Ord,Show,Read,Functor,Pointed,Applicative,Alternative,Copointed)

instance Alternative f => Monoid (WrappedApplicative f a) where
    mempty = empty 
    WrappedApplicative a `mappend` WrappedApplicative b = WrappedApplicative (a <|> b) 

instance (Alternative f, Monoid a) => Multiplicative (WrappedApplicative f a) where
    one = pure mempty
    times = liftA2 mappend

instance (Alternative f, c `Reducer` a) => Reducer c (WrappedApplicative f a) where
    unit = WrappedApplicative . pure . unit

instance (Alternative f, Monoid a) => LeftSemiNearRing (WrappedApplicative f a)

-- | if @m@ is a 'Module' and @f@ is a 'Applicative' then @f `TraversalWith` m@ is a 'Module' as well

newtype TraversalWith f m = TraversalWith { getTraversalWith :: f m } 
    deriving (Eq,Ord,Show,Read,Functor,Pointed,Applicative,Alternative,Copointed)

instance (Monoid m, Applicative f) => Monoid (f `TraversalWith` m) where
    mempty = pure mempty
    mappend = liftA2 mappend

instance (Group m, Applicative f) => Group (f `TraversalWith` m) where
    gnegate = fmap gnegate
    minus = liftA2 minus
    gsubtract = liftA2 gsubtract

instance (c `Reducer` m, Applicative f) => Reducer c (f `TraversalWith` m) where
    unit = pure . unit

instance (LeftModule r m, Applicative f) => LeftModule r (f `TraversalWith` m) where
    x *. m = (x *.) <$> m

instance (RightModule r m, Applicative f) => RightModule r (f `TraversalWith` m) where
    m .* y = (.* y) <$> m

instance (Module r m, Applicative f) => Module r (f `TraversalWith` m)