Expressing interpreters as natural transformations from syntax to semantics

State.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
import Control.Applicative
import Control.Monad
import qualified Control.Monad.State as FState
import Control.Monad.ST
import Data.STRef

type NaturalTranformation f g = forall a. f a -> g a
type (~>) f g = NaturalTranformation f g

type Id a = a

{- Free constructions -}

data FreeF (f :: * -> *) :: * -> * where
  FMap :: (a -> b) -> f a -> FreeF f b

instance Functor (FreeF f) where
  fmap g (FMap f x) = FMap (g . f) x

data FreeM (f :: * -> *) :: * -> * where
  Z :: a                   -> FreeM f a
  S :: FreeF f (FreeM f a) -> FreeM f a

instance Functor (FreeM f) where
  fmap f (Z x) = Z (f x)
  fmap f (S x) = S (fmap (fmap f) x)

instance Applicative (FreeM f) where
  pure  = return
  (<*>) = ap

instance Monad (FreeM f) where
  return    = Z
  Z x >>= f = f x
  S x >>= f = S (fmap (>>= f) x)

{- Generic binders for free monad -}

injM :: f ~> FreeM f
injM x = S (FMap Z x)

type Unit f = Id ~> f
type Bind f = forall a b. (a -> f b) -> (f a -> f b)

runFreeM :: Unit g -> Bind g -> (f ~> g) -> FreeM f a -> g a
runFreeM unit bind eta (Z x)          = unit x
runFreeM unit bind eta (S (FMap f x)) = bind (runFreeM unit bind eta . f) (eta x)

{- Abstract state monad -}

data StateF s :: * -> * where
  Get ::      StateF s s
  Put :: s -> StateF s ()

type State s a = FreeM (StateF s) a

get :: State s s
get = injM Get

put :: s -> State s ()
put = injM . Put

type StateSemantics s a = s -> (a, s)

type StateInterpreter s = State s ~> StateSemantics s

{- Functional state interpreter -}

runFState :: StateInterpreter s
runFState = FState.runState . runFreeM return (=<<) eta
  where
    eta :: StateF s ~> FState.State s
    eta Get     = FState.get
    eta (Put s) = FState.put s

{- ST-based interpreter -}

runSTState :: StateInterpreter s
runSTState x s = runST $ do
  h <- newSTRef s
  a <- runFreeM return (=<<) (eta h) x
  s' <- readSTRef h
  return (a, s')
    where
      eta :: STRef c s -> (StateF s ~> ST c)
      eta h Get     = readSTRef h
      eta h (Put s) = writeSTRef h s

{- Tests -}

test :: State String Int
test = do
  s <- get
  put $ s ++ " " ++ s
  return $ length s

main :: IO ()
main = do
  let input = "foobar"
  putStrLn $ "Functional state interpreter: " ++ show (runFState test input)
  putStrLn $ "ST-based state interpreter: " ++ show (runSTState test input)