有名な型クラスのメモ

State.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}

import Prelude hiding (Functor, fmap,
                       Applicative, (<*>), (<$>), pure,
                       Monad, return, (>>=), (>>), fail, join
                      )

-- 型クラス
class Functor f where
  fmap :: (a -> b) -> f a -> f b
  -- 法則
  -- fmap id = id
  -- fmap (g . h) = fmap g . fmap h

class Functor f => Pointed f where
  pure :: a -> f a
  -- 法則
  -- fmap g . pure = pure . g

class Pointed f => Applicative f where
  (<*>) :: f (a -> b) -> f a -> f b
  (<$>) :: (a -> b) -> (f a -> f b)
  (<$>) = fmap -- デフォルト実装
  -- 法則
  -- (<$>) g x = pure g <*> x

class Applicative m => Monad m where
  -- どちらかの実装が必要
  (>>=) :: m a -> (a -> m b) -> m b
  (>>=) m f = join $ fmap f m   -- fmap f m :: (a -> m b) -> m a -> m (m b)
  join :: m (m a) -> m a
  join m = m >>= id             -- (>>=) m id :: m a -> (a -> a) -> a

  -- デフォルト実装
  (>>)  :: m a -> m b -> m b
  m >> n = m >>= \_ -> n        --  結果を捨てる
  return :: a -> m a
  return = pure


-- 実装

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

instance Functor (State s) where
  fmap :: (a -> b) -> (State s) a -> (State s) b
  fmap f m = State $ \s ->
    let (a, s1) = runState m s in (f a, s1)

instance Pointed (State s) where
  pure :: a -> (State s) a
  pure =  State . (,)

instance Applicative (State s) where
  (<*>) :: State s (a -> b) -> State s a -> State s b
  State sf <*> State sa = State $ \s ->
    let (f, s1) = sf s
        (a, s2) = sa s1
    in (f a, s2)

instance Monad (State s) where
  (>>=) :: State s a -> (a -> State s b) -> State s b
  State sa >>= sf = State $ \s ->
    let (a, s1)  = sa s
        State sb = sf a
    in sb s1