Monadoid.hs

{-# LANGUAGE PolyKinds, GADTs, FlexibleInstances #-}

import Data.Char (ord)
import Control.Arrow (first)

-- Basic class definitions.

class Functor2 (f :: κ -> λ -> * -> *) where
    fmap2 :: (a -> b) -> (f i j a -> f i j b)

class Functor2 m => Monadoid (m :: κ -> κ -> * -> *) where
    returnoid :: a -> m i i a
    joinoid :: m i j (m j k a) -> m i k a
    (.>>=) :: m i j a -> (a -> m j k b) -> m i k b
    (.>=>) :: (a -> m i j b) -> (b -> m j k c) -> (a -> m i k c)

    m .>>= f = (\() -> m) .>=> f $ ()
    f .>=> g = joinoid . fmap2 g . f
    joinoid m = m .>>= id

infixl 1 .>>=
infixr 1 .>=>

-- Type-changing State monad.

newtype Stateoid s t a = Stateoid { runStateoid :: s -> (a,t) }

instance Functor2 Stateoid where
    fmap2 f (Stateoid m) = Stateoid $ \s -> first f (m s)

instance Monadoid Stateoid where
    returnoid a = Stateoid $ \s -> (a,s)
    Stateoid m .>>= f = Stateoid $ \s -> k f (m s) where
        k f (a,t) = runStateoid (f a) t

get :: Stateoid s s s
get = Stateoid $ \s -> (s,s)

gets :: (s -> a) -> Stateoid s s a
gets f = Stateoid $ \s -> (f s,s)

modify :: (s -> t) -> Stateoid s t ()
modify f = Stateoid $ \s -> ((), f s)

put :: t -> Stateoid s t ()
put t = Stateoid $ \_ -> ((), t)

-- Everybody loves examples.

test :: (Int, [Int])
test = flip runStateoid () $
            put "hello" .>>= \_ ->          -- Stateoid ()     String ()
            modify (map ord) .>>= \_ ->     -- Stateoid String [Int]  ()
            get .>>= \a ->                  -- Stateoid [Int]  [Int]  [Int]
            returnoid (sum a)               -- Stateoid [Int]  [Int]  Int
-- test = (532,[104,101,108,108,111])

-- Wrappers nobody cares about.

newtype Wrap2 f i j a = Wrap2 { unWrap2 :: f a }
    deriving (Eq, Show)

instance Functor f => Functor2 (Wrap2 f) where
    fmap2 f (Wrap2 a) = Wrap2 (fmap f a)

instance (Functor f, Monad f) => Monadoid (Wrap2 f) where
    returnoid a = Wrap2 (return a)
    Wrap2 m .>>= f = Wrap2 (m >>= unWrap2 . f)

instance Functor2 f => Functor (f i i) where
    fmap = fmap2

instance Monadoid f => Monad (f i i) where
    return = returnoid
    (>>=) = (.>>=)