スタンピングモナド

monoid.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies, ScopedTypeVariables #-}
import Data.Void
import Data.Bifunctor
import Control.Comonad
import qualified Data.Monoid as M

-- i -> f はよくないかもしれない
class Bifunctor f => Monoidal i f | i -> f, f -> i where
  midL1 :: a -> f i a
  midL2 :: f i a -> a
  midR1 :: a -> f a i
  midR2 :: f a i -> a
  massoc1 :: f a (f b c) -> f (f a b) c
  massoc2 :: f (f a b) c -> f a (f b c)

class Monoidal i f => Monoid i f m where
  mid :: i -> m
  mmul :: f m m -> m

class Monoidal i f => Comonoid i f m where
  cid :: m -> i
  cmul :: m -> f m m

instance Monoidal () (,) where
  midL1 m = ((),m)
  midL2 = snd
  midR1 m = (m,())
  midR2 = fst
  massoc1 (a,(b,c)) = ((a,b),c)
  massoc2 ((a,b),c) = (a,(b,c))
instance M.Monoid m => Monoid () (,) m where
  mid = \_ -> M.mempty
  mmul = uncurry M.mappend
instance Comonoid () (,) a where
  cid = \_ -> ()
  cmul m = (m,m)

instance Monoidal Void Either where
  midL1 = Right
  midL2 = either mid id
  midR1 = Left
  midR2 = either id mid
  massoc1 = either (Left . Left) (either (Left . Right) Right)
  massoc2 = either (either Left (Right . Left)) (Right . Right)
instance Monoid Void Either a where
  mid = absurd
  mmul (Left m) = m
  mmul (Right m) = m

-- (コ)モノイドから(コ)モナドを生み出す
newtype StampL i f m a = StampL { runStampL :: f m a }
  deriving (Show)

instance Bifunctor f => Functor (StampL i f m) where
  fmap f (StampL x) = StampL $ second f x

instance Monoid i f m => Monad (StampL i f m) where
  return a = StampL $ first mid $ midL1 a
  StampL m >>= f = StampL $ first mmul $ massoc1 $ second (runStampL . f) m

instance Comonoid i f m => Comonad (StampL i f m) where
  extract (StampL m) = midL2 $ first cid m
  extend f (StampL m) = StampL $ second (f . StampL) $ massoc2 $ first cmul m

-- ただの双対
-- Dual みたいな型を作っておくほうがいいかも
-- もっとも (,) も Either も可換だからあまり嬉しくない
newtype StampR i f m a = StampR { runStampR :: f a m }
  deriving (Show)

instance Bifunctor f => Functor (StampR i f m) where
  fmap f (StampR x) = StampR $ first f x

instance Monoid i f m => Monad (StampR i f m) where
  return a = StampR $ second mid $ midR1 a
  StampR m >>= f = StampR $ second mmul $ massoc2 $ first (runStampR . f) m

instance Comonoid i f m => Comonad (StampR i f m) where
  extract (StampR m) = midR2 $ second cid m
  extend f (StampR m) = StampR $ first (f . StampR) $ massoc1 $ second cmul m