Dissecting the State monad with Operational and Free monads

dissecting-the-state-monad.md

The original article can be found here

freestate.hs

{-# LANGUAGE TemplateHaskell, FlexibleContexts, DeriveFunctor #-}

import Control.Monad (forM_)
import Control.Monad.Free
import Control.Monad.Free.TH

data StateCmd s a = Get (s -> a) | Put s a deriving (Functor)

type State s a = Free (StateCmd s) a

makeFree ''StateCmd

runState :: State s a -> s -> (a, s)
runState p s = case p of
  Pure x -> (x, s)
  Free (Get k) -> runState (k s) s
  Free (Put x k) -> runState k x

fib' :: (Integral a) => a -> State (a, a) a
fib' n = do
  forM_ [1..n] $ \_ -> do
    (a, b) <- get
    put (b, a+b)
  (a, b) <- get
  return a

fib :: (Integral a) => a -> a
fib n = fst $ runState (fib' n) (0, 1)

operationalstate.hs

{-# LANGUAGE GADTs #-}

import Control.Monad (forM_)
import Control.Monad.Operational

data StateCmd s a where
  Get :: StateCmd s s
  Put :: s -> StateCmd s ()

type State s a = Program (StateCmd s) a

get :: State s s
get = singleton Get

put :: s -> State s ()
put x = singleton (Put x)

runState :: State s a -> s -> (a, s)
runState p s = case (view p) of
  Return x -> (x, s)
  Get :>>= k -> runState (k s) s
  Put x :>>= k -> runState (k ()) x

fib' :: (Integral a) => a -> State (a, a) a
fib' n = do
  forM_ [1..n] $ \_ -> do
    (a, b) <- get
    put (b, a+b)
  (a, b) <- get
  return a

fib :: (Integral a) => a -> a
fib n = fst $ runState (fib' n) (0, 1)