```{-# LANGUAGE
DeriveFunctor,
TupleSections
#-}

{-|
Module      : Data.Monoid.Zero
Copyright   : (c) 2015 Maciej PirĂ³g
Stability   : experimental

Typeclasses for monoids with (left, right, or \"two-sided\") zero
elements (aka absorbing elements) and their free implementations.
Just like monoids are related to backtracking computations, right
zero monoids are related to backtracking computation with Prolog's
cut operator (see the module "Data.List.Cut").
-}
module Data.Monoid.Zero
(
-- * Zero monoids
MonoidZero(..),
-- * Left zero monoids
MonoidLZero(..),
-- * Right zero monoids
MonoidRZero(..),
)
where

import Control.Applicative (pure, (<\$>))
import Data.Foldable (Foldable (..))
import Data.Traversable (Traversable (..))
import Data.Monoid (Monoid(..), Product(..), All(..), Any(..))

--
-- MONOID ZERO
--

-- | Class of zero monoids. Instances should satisfy:
--
-- * @'mappend' zero m = zero@
--
-- * @'mappend' m zero = zero@
class (Monoid m) => MonoidZero m where
zero :: m

-- | A zero monoid freely generated by a monoid.
deriving (Functor, Eq, Ord)

instance (Show m) => Show (AdjoinZero m) where
show (AdjoinZero (Just m)) = show m

foldMap f (AdjoinZero (Just m)) = f m
foldMap f (AdjoinZero Nothing)  = mempty

traverse f (AdjoinZero (Just a)) = AdjoinZero . Just <\$> f a

instance (Monoid m) => Monoid (AdjoinZero m) where
mempty = AdjoinZero \$ Just \$ mempty
AdjoinZero \$ Just (m `mappend` n)

instance (Monoid m) => MonoidZero (AdjoinZero m) where

instance (Monoid m) => MonoidLZero (AdjoinZero m) where

instance (Monoid m) => MonoidRZero (AdjoinZero m) where

instance (Num n) => MonoidZero (Product n) where
zero = Product 0

instance MonoidZero All where
zero = All False

instance MonoidZero Any where
zero = Any True

instance MonoidZero () where
zero = ()

instance (MonoidZero a, MonoidZero b) => MonoidZero (a, b) where
zero = (zero, zero)

instance (MonoidZero a, MonoidZero b, MonoidZero c) => MonoidZero (a, b, c) where
zero = (zero, zero, zero)

instance (MonoidZero a, MonoidZero b, MonoidZero c, MonoidZero d) => MonoidZero (a, b, c, d) where
zero = (zero, zero, zero, zero)

instance (MonoidZero a, MonoidZero b, MonoidZero c, MonoidZero d, MonoidZero e) => MonoidZero (a, b, c, d, e) where
zero = (zero, zero, zero, zero, zero)

--
-- MONOID LZERO
--

-- | Class of left zero monoids. Instances should satisfy:
--
-- * @'mappend' m lzero = lzero@
class (Monoid m) => MonoidLZero m where
lzero :: m

-- | A left zero monoid freely generated by a monoid.
deriving (Functor, Eq, Ord)

foldMap f (AdjoinLZero (_, a)) = f a

traverse f (AdjoinLZero (b, a)) = AdjoinLZero . (b, ) <\$> f a

instance (Show m) => Show (AdjoinLZero m) where
show (AdjoinLZero (b, m)) = (if b then "*" else "") ++ show m

instance (Monoid m) => Monoid (AdjoinLZero m) where

instance (Monoid m) => MonoidLZero (AdjoinLZero m) where

instance (Num n) => MonoidLZero (Product n) where
lzero = Product 0

instance MonoidLZero All where
lzero = All False

instance MonoidLZero Any where
lzero = Any True

instance MonoidLZero () where
lzero = ()

instance (MonoidLZero a, MonoidLZero b) => MonoidLZero (a, b) where
lzero = (lzero, lzero)

instance (MonoidLZero a, MonoidLZero b, MonoidLZero c) => MonoidLZero (a, b, c) where
lzero = (lzero, lzero, lzero)

instance (MonoidLZero a, MonoidLZero b, MonoidLZero c, MonoidLZero d) => MonoidLZero (a, b, c, d) where
lzero = (lzero, lzero, lzero, lzero)

instance (MonoidLZero a, MonoidLZero b, MonoidLZero c, MonoidLZero d, MonoidLZero e) => MonoidLZero (a, b, c, d, e) where
lzero = (lzero, lzero, lzero, lzero, lzero)

--
-- MONOID RZERO
--

-- | Class of right zero monoids. Instances should satisfy:
--
-- * @'mappend' rzero m = rzero@
class (Monoid m) => MonoidRZero m where
rzero :: m

-- | A right zero monoid freely generated by a monoid.
deriving (Functor, Eq, Ord)

foldMap f (AdjoinRZero (a, _)) = f a

traverse f (AdjoinRZero (a, b)) = AdjoinRZero . (, b) <\$> f a

instance (Show m) => Show (AdjoinRZero m) where
show (AdjoinRZero (m, b)) = show m ++ (if b then "*" else "")

instance (Monoid m) => Monoid (AdjoinRZero m) where

instance (Monoid m) => MonoidRZero (AdjoinRZero m) where

instance (Num n) => MonoidRZero (Product n) where
rzero = Product 0

instance MonoidRZero All where
rzero = All False

instance MonoidRZero Any where
rzero = Any True

instance MonoidRZero () where
rzero = ()

instance (MonoidRZero a, MonoidRZero b) => MonoidRZero (a, b) where
rzero = (rzero, rzero)

instance (MonoidRZero a, MonoidRZero b, MonoidRZero c) => MonoidRZero (a, b, c) where
rzero = (rzero, rzero, rzero)

instance (MonoidRZero a, MonoidRZero b, MonoidRZero c, MonoidRZero d) => MonoidRZero (a, b, c, d) where
rzero = (rzero, rzero, rzero, rzero)

instance (MonoidRZero a, MonoidRZero b, MonoidRZero c, MonoidRZero d, MonoidRZero e) => MonoidRZero (a, b, c, d, e) where
rzero = (rzero, rzero, rzero, rzero, rzero)
```