Monoids.hs

{-# LANGUAGE MultiParamTypeClasses
           , FlexibleInstances
           , GeneralizedNewtypeDeriving
           , DeriveFunctor
           , TypeFamilies
           , TypeOperators
  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Diagrams.Monoids
-- Copyright   :  (c) 2011 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Various monoid-related definitions (monoid actions, split monoids,
-- applicative monoids) used in the core diagrams library.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Diagrams.Monoids
       ( -- * Monoid actions

         Action(..)

         -- * Split monoids
         -- $split

       , Split(..), split

         -- * Forgetful monoids
         -- $forget

       , Forgetful(..), unForget, forget

         -- * Applicative monoids

       , AM(..), inAM2

         -- * Coproduct monoid
       , (:+:)
       , inL, inR
       , mappendL, mappendR
       , killL, killR
       , untangle
       ) where

import Graphics.Rendering.Diagrams.V
import Graphics.Rendering.Diagrams.Util

import Data.Monoid
import Data.Foldable
import Control.Applicative
import Data.Either (lefts, rights)

------------------------------------------------------------
--  Monoid actions
------------------------------------------------------------

-- | Type class for monoid actions, where monoidal values of type @m@
--   \"act\" on values of another type @s@.  Instances are required to
--   satisfy the laws
--
--   * @act mempty = id@
--
--   * @act (m1 ``mappend`` m2) = act m1 . act m2@
--
--   Additionally, if the type @s@ has any algebraic structure, @act
--   m@ should be a homomorphism.  For example, if @s@ is also a
--   monoid we should have @act m mempty = mempty@ and @act m (s1
--   ``mappend`` s2) = (act m s1) ``mappend`` (act m s2)@.
--
--   By default, @act = const id@, so for a monoidal type @M@ which
--   should have no action on anything, it suffices to write
--
--   > instance Action M s
--
--   with no method implementations.
class Action m s where

  -- | Convert a monoidal value of type @m@ to an action on @s@ values.
  act :: m -> s -> s
  act = const id

------------------------------------------------------------
--  Split monoids
------------------------------------------------------------

-- $split
-- Sometimes we want to accumulate values from some monoid, but have
-- the ability to introduce a \"split\" which separates values on
-- either side.  For example, this is used when accumulating
-- transformations to be applied to primitive diagrams: the 'freeze'
-- operation introduces a split, since only transformations occurring
-- outside the freeze should be applied to attributes.

infix 5 :|

-- | A value of type @Split m@ is either a single @m@, or a pair of
--   @m@'s separated by a divider.
data Split m = M m
             | m :| m

-- | If @m@ is a @Monoid@, then @Split m@ is a monoid which combines
--   values on either side of a split, keeping only the rightmost
--   split.
instance Monoid m => Monoid (Split m) where
  mempty = M mempty

  (M m1)       `mappend` (M m2)       = M (m1 <> m2)
  (M m1)       `mappend` (m1' :| m2)  = m1 <> m1'         :| m2
  (m1  :| m2)  `mappend` (M m2')      = m1                :| m2 <> m2'
  (m11 :| m12) `mappend` (m21 :| m22) = m11 <> m12 <> m21 :| m22

-- | A convenient name for @mempty :| mempty@, so @a \<\> split \<\> b == a :| b@.
split :: Monoid m => Split m
split = mempty :| mempty

-- | By default, the action of a split monoid is the same as for
--   the underlying monoid, as if the split were removed.
instance Action m n => Action (Split m) n where
  act (M m) n      = act m n
  act (m1 :| m2) n = act m1 (act m2 n)

------------------------------------------------------------
--  Forgetful monoids
------------------------------------------------------------

-- $forget
-- Sometimes we want to be able to "forget" some information.  In
-- particular, we can introduce special @Forgetful@ values which cause
-- anything to their right to be forgotten.

-- | A value of type @Forgetful m@ is either a \"normal\" value of
--   type @m@, which combines normally with other normal values, or a
--   \"forgetful\" value, which combines normally with other values to
--   its left but discards values combined on the right.  Also, when
--   combining a forgetful value with a normal one the result is
--   always forgetful.
data Forgetful m = Normal m
                 | Forgetful m
  deriving Functor

unForget :: Forgetful m -> m
unForget (Normal m)    = m
unForget (Forgetful m) = m

-- | If @m@ is a 'Monoid', then @Forgetful m@ is a monoid with two
--   sorts of values, \"normal\" and \"forgetful\": the normal ones
--   combine normally and the forgetful ones discard anything to the
--   right.
instance Monoid m => Monoid (Forgetful m) where
  mempty = Normal mempty

  (Normal m1)    `mappend` (Normal m2)    = Normal (m1 <> m2)
  (Normal m1)    `mappend` (Forgetful m2) = Forgetful (m1 <> m2)
  (Forgetful m1) `mappend` _              = Forgetful m1

-- | A convenient name for @Forgetful mempty@, so @a \<\> forget \<\>
--   b == Forgetful a@.
forget :: Monoid m => Forgetful m
forget = Forgetful mempty

instance Action m n => Action (Forgetful m) n where
  act (Normal m) n    = act m n
  act (Forgetful m) n = act m n

type instance V (Forgetful m) = V m

------------------------------------------------------------
--  Applicative monoids
------------------------------------------------------------

-- | A wrapper for an 'Applicative' structure containing a monoid.
--   Such structures have a @Monoid@ instance based on \"idiomatic\"
--   application of 'mappend' within the @Applicative@ context.
--   @instance Monoid m => Monoid (e -> m)@ is one well-known special
--   case.  (However, the standard @Monoid@ instance for @Maybe@ is
--   /not/ an instance of this pattern; nor is the standard instance
--   for lists.)
newtype AM f m = AM (f m)
  deriving (Functor, Applicative)

-- | Apply a binary function inside an 'AM' newtype wrapper.
inAM2 :: (f m -> f m -> f m) -> AM f m -> AM f m -> AM f m
inAM2 g (AM f1) (AM f2) = AM (g f1 f2)

-- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@.
instance (Applicative f, Monoid m) => Monoid (AM f m) where
  mempty  = pure mempty
  mappend = inAM2 (liftA2 mappend)

{- See Applicative laws here:

http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Applicative.html#t:Applicative
-}

{- left identity:

  AM (pure mempty) `mappend` AM f
=           { definition }
  AM $ fmap mappend (pure mempty) <*> f
=           { naturality of pure, fmap f . pure = pure . f }
  AM $ pure (mappend mempty) <*> f
=           { monoid law (left identity) }
  AM $ pure id <*> f
=           { applicative law (identity) }
  AM f
-}

{- right identity:

  AM f `mappend` AM (pure mempty)
=           { definition }
  AM $ fmap mappend f <*> pure mempty
=           { applicative law (interchange) }
  AM $ pure ($mempty) <*> fmap mappend f
=           { applicative/functor law }
  AM $ pure ($mempty) <*> (pure mappend <*> f)
=           { applicative law (composition) }
  AM $ pure (.) <*> pure ($mempty) <*> pure mappend <*> f
=           { applicative law (homomorphism) }
  AM $ pure ((.) ($mempty)) <*> pure mappend <*> f
=           { applicative law (homomorphism) }
  AM $ pure (($mempty) . mappend) <*> f
=           { monoid law (right identity) }
  AM $ pure id <*> f
=           { applicative law (identity) }
  AM f
-}

{- associativity:

  (AM f1 `mappend` AM f2) `mappend` AM f3
=           { definition }
  AM $ fmap mappend (AM f1 `mappend` AM f2) <*> f3
=           { definition }
  AM $ fmap mappend (fmap mappend f1 <*> f2) <*> f3
=           { applicative/functor law }
  AM $ pure mappend <*> (pure mappend <*> f1 <*> f2) <*> f3
=           { applicative law (composition) }
  AM $ pure (.) <*> pure mappend <*> (pure mappend <*> f1) <*> f2 <*> f3
=           { applicative law (homomorphism) }
  AM $ pure (mappend .) <*> (pure mappend <*> f1) <*> f2 <*> f3
=           { applicative law (composition) }
  AM $ pure (.) <*> pure (mappend .) <*> pure mappend <*> f1 <*> f2 <*> f3
=           { applicative law (homomorphism) }
  AM $ pure ((mappend .) . mappend) <*> f1 <*> f2 <*> f3
=           { monoid law (associativity) }
  AM $ pure ((. mappend) . (.) . mappend) <*> f1 <*> f2 <*> f3
=
  -- XXX finish this proof (although I have no doubt it goes through)


=
  AM f1 `mappend` (AM f2 `mappend` AM f3)
-}

{-
\x y z -> (x `mappend` y) `mappend` z
\x y -> mappend (mappend x y)
\x -> mappend . (mappend x)
(mappend .) . mappend
-}

{-
\x y z -> x `mappend` (y `mappend` z)
\x y z -> mappend x (mappend y z)
\x y -> mappend x . mappend y
\x -> ((.) (mappend x)) . mappend
\x -> (.) ((.) (mappend x)) mappend
\x -> (.mappend) ((.) (mappend x))
(. mappend) . (.) . mappend
-}


-- | An applicative monoid acts on a value of a monoidal type by
--   having each element in the structure act on the value
--   independently, and then folding the resulting structure.
instance (Action m n, Foldable f, Functor f, Monoid n) => Action (AM f m) n where
  act (AM f) n = fold $ fmap (`act` n) f

-- XXX need to prove that this satisfies the laws!  There are other
-- "obvious" instances too.

------------------------------------------------------------
-- Monoid coproduct
------------------------------------------------------------

-- | @m :+: n@ is the coproduct of monoids @m@ and @n@.  Values of
--   type @m :+: n@ consist of alternating lists of @m@ and @n@
--   values.  The empty list is the identity, and composition is list
--   concatenation, with appropriate combining of adjacent elements
--   when possible.
newtype m :+: n = MCo { unMCo :: [Either m n] }

-- For efficiency and simplicity, we implement it just as [Either m
-- n]: of course, this does not preserve the invariant of strictly
-- alternating types, but it doesn't really matter as long as we don't
-- let anyone inspect the internal representation.

-- | Injection from the left monoid into a coproduct.
inL :: m -> m :+: n
inL m = MCo [Left m]

-- | Injection from the right monoid into a coproduct.
inR :: n -> m :+: n
inR n = MCo [Right n]

-- | Prepend a value from the left monoid.
mappendL :: m -> m :+: n -> m :+: n
mappendL = mappend . inL

-- | Prepend a value from the right monoid.
mappendR :: n -> m :+: n -> m :+: n
mappendR = mappend . inR

{-
normalize :: (Monoid m, Monoid n) => m :+: n -> m :+: n
normalize (MCo es) = MCo (normalize' es)
  where normalize' []  = []
        normalize' [e] = [e]
        normalize' (Left e1:Left e2 : es) = normalize' (Left (e1 <> e2) : es)
        normalize' (Left e1:es) = Left e1 : normalize' es
        normalize' (Right e1:Right e2:es) = normalize' (Right (e1 <> e2) : es)
        normalize' (Right e1:es) = Right e1 : normalize' es
-}

-- | The coproduct of two monoids is itself a monoid.
instance Monoid (m :+: n) where
  mempty = MCo []
  (MCo es1) `mappend` (MCo es2) = MCo (es1 ++ es2)

-- | @killR@ takes a value in a coproduct monoid and sends all the
--   values from the right monoid to the identity.
killR :: Monoid m => m :+: n -> m
killR = mconcat . lefts . unMCo

-- | @killL@ takes a value in a coproduct monoid and sends all the
--   values from the left monoid to the identity.
killL :: Monoid n => m :+: n -> n
killL = mconcat . rights . unMCo

-- | Take a value from a coproduct monoid where the left monoid has an
--   action on the right, and \"untangle\" it into a pair of values.  In
--   particular,
--
-- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ...
--
--   is sent to
--
-- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...)
--
--   That is, before combining @n@ values, every @n@ value is acted on
--   by all the @m@ values to its left.
untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n)
untangle (MCo elts) = untangle' mempty elts
  where untangle' cur [] = cur
        untangle' (curM, curN) (Left m : elts')  = untangle' (curM <> m, curN) elts'
        untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN <> act curM n) elts'

-- | Coproducts act on other things by having each of the components
--   act individually.
instance (Action m r, Action n r) => Action (m :+: n) r where
  act = appEndo . mconcat . map Endo . map (either act act) . unMCo