Here's the code:
{-# LANGUAGE FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses,
FunctionalDependencies, GeneralizedNewtypeDeriving, UndecidableInstances #-}
import Control.Arrow (first, second, left, right)
import Data.Monoid
data Void
data Iso a b = Iso { from :: a -> b, to :: b -> a}
-- monoidal category (Hask, m, unit)
class MonoidalCategory m unit | m -> unit where
iso1 :: Iso (m (m x y) z) (m x (m y z))
iso2 :: Iso x (m x unit)
iso3 :: Iso x (m unit x)
map1 :: (a -> b) -> (m a c -> m b c)
map2 :: (a -> b) -> (m c a -> m c b)
instance MonoidalCategory (,) () where
iso1 = Iso (\((x,y),z) -> (x,(y,z))) (\(x,(y,z)) -> ((x,y),z))
iso2 = Iso (\x -> (x,())) (\(x,()) -> x)
iso3 = Iso (\x -> ((),x)) (\((),x) -> x)
map1 = first
map2 = second
instance MonoidalCategory Either Void where
iso1 = Iso f g
where f (Left (Left x)) = Left x
f (Left (Right x)) = Right (Left x)
f (Right x) = Right (Right x)
g (Left x) = Left (Left x)
g (Right (Left x)) = Left (Right x)
g (Right (Right x)) = Right x
iso2 = Iso Left (\(Left x) -> x)
iso3 = Iso Right (\(Right x) -> x)
map1 = left
map2 = right
-- monoid in monoidal category (Hask, c, u)
class MonoidM m c u | m -> c u where
mult :: c m m -> m
unit :: u -> m
-- object of monoidal category (Hask, Either, Void)
newtype Eith a = Eith { getEith :: a } deriving (Show)
-- object of monoidal category (Hask, (,), ())
newtype Monoid m => Mult m = Mult { getMult :: m } deriving (Monoid, Show)
instance MonoidM (Eith a) Either Void where
mult (Left x) = x
mult (Right x) = x
unit _ = undefined
instance Monoid m => MonoidM (Mult m) (,) () where
mult = uncurry mappend
unit = const mempty
instance (MonoidalCategory c u, MonoidM m c u) => Monad (c m) where
return = map1 unit . from iso3
x >>= f = (map1 mult . to iso1) (map2 f x)
Usage:
a = (Mult "hello", 5) >>= (\x -> (Mult " world", x+1))
-- (Mult {getMult = "hello world"}, 6)
inv 0 = Left (Eith "error")
inv x = Right (1/x)
b = Right 5 >>= inv -- Right 0.2
c = Right 0 >>= inv -- Left (Eith {getEith="error"})
d = Left (Eith "a") >>= inv -- Left (Eith {getEith="a"})