common-monads.hs

import Prelude hiding (Functor, Monad, (>>=), (>>), fmap)
import Data.Monoid (Monoid, mempty, (<>))

class Functor f where
  fmap :: (a -> b) -> f a -> f b

class Functor f => Applicative f where
  pure :: a -> f a
  (<*>) :: f (a -> b) -> f a -> f b

class Applicative f => Monad f where
  join :: f (f a) -> f a
  (>>=) :: f a -> (a -> f b) -> f b
  f >>= g = join (pure g <*> f)
  (>>) :: f a -> f b -> f b
  f >> g = f >>= const g

-- Reader

instance Functor ((->) env) where
	fmap f g e =  f $ g e

instance Applicative ((->) env) where
  pure = const
  f <*> g = \e -> f e $ g e

instance Monad ((->) env) where
  join f e = f e e

ask :: env -> env
ask = id

greeter :: String -> String
greeter = ask >>= \name -> pure $ "Hello " ++ name

-- Identity

data Identity a = Identity a
  deriving (Show)

instance Functor Identity where
  fmap f (Identity a) = Identity $ f a

instance Applicative Identity where
  pure = Identity
  (Identity f) <*> g =  fmap f g

instance Monad Identity where
  join (Identity f) = f

-- Writer

instance Monoid m => Functor ((,) m) where
  fmap f (a, b) = (a, f b)

instance Monoid m => Applicative ((,) m) where
  pure a = (mempty, a)
  (m, f) <*> (m', g) = (m <> m', f g)

instance Monoid m => Monad ((,) m) where
  join (m, (m', f)) = (m <> m', f)

tell :: Monoid m => m -> (m, ())
tell m = (m, ())

teller = tell "Hello " >> tell "World" >> pure 10 >>= (pure . (+2))

-- State

data State s a = State { runState :: s -> (s, a) }

instance Functor (State s) where
  fmap f (State g) = State $ \s ->
                     let (s', a) = g s
                     in (s', f a)

instance Applicative (State s) where
  pure a = State $ \s -> (s, a)
  (State f) <*> (State g) = State $ \s ->
                            let (s', f') = f s
                                (s'', a) = g s'
                            in (s'', f' a)

instance Monad (State s) where
  join (State f) = State $ \s ->
                   let (s', a) = f s
                   in runState a s'

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

set :: s -> State s ()
set a = State $ const (a, ())

modify :: (s -> s) -> State s ()
modify f = get >>= (set . f)

evalState :: State s a -> s -> a
evalState f = snd . (runState f)

execState :: State s a -> s -> s
execState f =  fst . (runState f)

stateful = modify (*5) >> get >>= \n -> pure $ if n < 50 then n / 2 else n * 4