Associative.hs

-- {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
-------------------------------------------------------------------------------------------
-- |
-- Module	: Control.Bifunctor.Associative
-- Copyright 	: 2008 Edward Kmett
-- License	: BSD
--
-- Maintainer	: Edward Kmett <ekmett@gmail.com>
-- Stability	: experimental
-- Portability	: non-portable (class-associated types)
--
-- NB: this contradicts another common meaning for an 'Associative' 'Category', which is one 
-- where the pentagonal condition does not hold, but for which there is an identity.
--
-------------------------------------------------------------------------------------------
module Control.Bifunctor.Associative 
	( module Control.Bifunctor
	, Associative(..)
	, Coassociative(..)
	) where

import Control.Bifunctor

{- | A category with an associative bifunctor satisfying Mac Lane\'s pentagonal coherence identity law:

> bimap id associate . associate . bimap associate id = associate . associate
-}
class Bifunctor p => Associative p where
	associate :: p (p a b) c -> p a (p b c)

{- | A category with a coassociative bifunctor satisyfing the dual of Mac Lane's pentagonal coherence identity law:

> bimap coassociate id . coassociate . bimap id coassociate = coassociate . coassociate
-}
class Bifunctor s => Coassociative s where
	coassociate :: s a (s b c) -> s (s a b) c

{-# RULES
"copentagonal coherence" bimap coassociate id . coassociate . bimap id coassociate = coassociate . coassociate
"pentagonal coherence" bimap id associate . associate . bimap associate id = associate . associate
 #-}

instance Associative (,) where
        associate ((a,b),c) = (a,(b,c))

instance Coassociative (,) where
        coassociate (a,(b,c)) = ((a,b),c)

instance Associative Either where
        associate (Left (Left a)) = Left a
        associate (Left (Right b)) = Right (Left b)
        associate (Right c) = Right (Right c)

instance Coassociative Either where
        coassociate (Left a) = Left (Left a)
        coassociate (Right (Left b)) = Left (Right b)
        coassociate (Right (Right c)) = Right c