MonadMonoid.hs

-- https://gist.github.com/pufuwozu/5550437
import Prelude hiding ((.), id)
import Control.Arrow
import Control.Category
import Data.Monoid

{-
class Monoid m where
  mappend :: m -> m -> m
  mempty :: m

mconcat :: Monoid m => [m] -> m
mconcat = foldr mappend mempty
-}

newtype MonadMonoid m a = MonadMonoid { getMonad :: a -> m a }

instance Monad m => Monoid (MonadMonoid m a) where
  mappend f g = MonadMonoid (\a -> getMonad f a >>= getMonad g)
  mempty = MonadMonoid return

newtype EndoCat c a = EndoCat {runEndoCat :: c a a}

instance Category c => Monoid (EndoCat c a) where
    mempty = EndoCat id
    EndoCat lhs `mappend` EndoCat rhs = EndoCat $ lhs . rhs

validations1 :: [MonadMonoid Maybe String]
validations1 =
    fmap MonadMonoid [\x -> if x == "Bad" then Nothing else Just x 
                     , \x -> if x == "Invalid" then Nothing else Just x ]

validations2 :: [EndoCat (Kleisli Maybe) String]
validations2 =
    fmap (EndoCat . Kleisli) [\x -> if x == "Bad" then Nothing else Just x
                             , \x -> if x == "Invalid" then Nothing else Just x]

main :: IO ()
main = do
  print $ (runKleisli . runEndoCat) (mconcat validations2) "Bad"
  print $ (runKleisli . runEndoCat) (mconcat validations2) "Invalid"
  print $ (runKleisli . runEndoCat) (mconcat validations2) "Good!"
  print . getMonad (mconcat validations1) $ "Bad"
  print . getMonad (mconcat validations1) $ "Invalid"
  print . getMonad (mconcat validations1) $ "Good!"

{-
Nothing
Nothing
Just "Good!"
Nothing
Nothing
Just "Good!"
-}