module Data.Category.Monoid where
import Prelude hiding ((.), Functor)
import Data.Monoid
import Data.Category
import Data.Category.Functor
import Data.Category.NaturalTransformation
import Data.Category.Adjunction (Adjunction, mkAdjunction, adjunctionMonad, adjunctionComonad, leftAdjunct, rightAdjunct)
import Data.Category.Monoidal
data MonoidA m a b where
MonoidA :: Monoid m => m -> MonoidA m m m
instance Monoid m => Category (MonoidA m) where
src (MonoidA _) = MonoidA mempty
tgt (MonoidA _) = MonoidA mempty
MonoidA a . MonoidA b = MonoidA $ a `mappend` b
data Mon :: * -> * -> * where
MonoidMorphism :: (Monoid m1, Monoid m2) => (m1 -> m2) -> Mon m1 m2
unMonoidMorphism :: (Monoid m1, Monoid m2) => Mon m1 m2 -> m1 -> m2
unMonoidMorphism (MonoidMorphism f) = f
instance Category Mon where
src (MonoidMorphism _) = MonoidMorphism id
tgt (MonoidMorphism _) = MonoidMorphism id
MonoidMorphism f . MonoidMorphism g = MonoidMorphism $ f . g
data ForgetMonoid = ForgetMonoid
type instance Dom ForgetMonoid = Mon
type instance Cod ForgetMonoid = (->)
type instance ForgetMonoid :% a = a
instance Functor ForgetMonoid where
ForgetMonoid % MonoidMorphism f = f
data FreeMonoid = FreeMonoid
type instance Dom FreeMonoid = (->)
type instance Cod FreeMonoid = Mon
type instance FreeMonoid :% a = [a]
instance Functor FreeMonoid where
FreeMonoid % f = MonoidMorphism $ map f
freeMonoidAdj :: Adjunction Mon (->) FreeMonoid ForgetMonoid
freeMonoidAdj = mkAdjunction FreeMonoid ForgetMonoid (\_ -> (:[])) (\(MonoidMorphism _) -> MonoidMorphism mconcat)
foldMap :: Monoid m => (a -> m) -> [a] -> m
foldMap = unMonoidMorphism . rightAdjunct freeMonoidAdj (MonoidMorphism id)
listMonadReturn :: a -> [a]
listMonadReturn = unit (adjunctionMonad freeMonoidAdj) ! id
listMonadJoin :: [[a]] -> [a]
listMonadJoin = multiply (adjunctionMonad freeMonoidAdj) ! id
listComonadExtract :: Monoid m => [m] -> m
listComonadExtract = let MonoidMorphism f = counit (adjunctionComonad freeMonoidAdj) ! MonoidMorphism id in f
listComonadDuplicate :: Monoid m => [m] -> [[m]]
listComonadDuplicate = let MonoidMorphism f = comultiply (adjunctionComonad freeMonoidAdj) ! MonoidMorphism id in f