Try implementing a FSM

.gitignore

*~
.#*
\#*\#

Fsm.hs

module Fsm where

import Control.Monad.State(runStateT, liftIO, get, put)

data Fsm s a = Fsm { 
  transition :: a -> s -> s,
  currentState :: s,
  callback :: s -> s -> IO ()
  }


input i = do 
  fsm@(Fsm transition currentState callback) <- get
  let nextState = transition i currentState
  liftIO (callback currentState nextState)
  put $ fsm {currentState = nextState}
  

evalFsm fsm@(Fsm transition initialState callback) computation = do
  (_, (Fsm transition state callback)) <- runStateT computation fsm
  return state

FsmRef.hs

import Data.IORef (IORef, readIORef, writeIORef, newIORef)


data Fsm s a = Fsm {
  fsmTransition :: a -> s -> s,
  fsmCurrentState :: IORef s,
  fsmCallback :: s -> s -> IO ()
  }


newFsm :: (a -> s -> s) -> s -> (s -> s -> IO ()) -> IO (Fsm s a)
newFsm t s c = do 
  stateRef <- newIORef s
  return $ Fsm t stateRef c


input :: Fsm s a -> a -> IO ()
input (Fsm trans stRef cb) action = do 
  state <- readIORef stRef
  let newState = trans action state
  writeIORef stRef newState
  cb state newState


fsmAction :: (a -> s -> s) -> s -> (s -> s -> IO ()) -> IO (a -> IO ())
fsmAction t s c = do
  fsm <- newFsm t s c
  return $ input fsm

data State = Dead | Alive | Vampire deriving Show

data Action = Kill | Bite deriving Show


transition :: Action -> State -> State
transition Bite Alive = Vampire
transition Kill _ = Dead


callback :: State -> State -> IO ()
callback _ Dead = putStrLn "Dead!"
callback from to = putStrLn $ "transition from " ++ show from ++ " to " ++ show to 


main :: IO ()
main = do
  action <- fsmAction transition Alive callback
  action Bite
  action Kill
  return ()

FsmState.hs

module Fsm where

import Control.Monad.State(runStateT, liftIO, get, put)

data State s = State s
data Action a = Action a
data Transition a s = Transition (Action a -> State s -> State s)
data Callback s = Callback (State s -> State  s -> IO ())

input (Transition transition) (Callback callback) action = do
  state <- get
  let nextState = transition action state
  put nextState
  liftIO $ callback state nextState

runFsm initialState transition callback actionComputation = 
  runStateT (actionComputation action) initialState
  where 
    action a = input transition callback (Action a)

-----------

data VampireState = Dead | Alive | Vampire deriving Show
data VampireAction = Kill | Bite deriving Show

transition :: Action VampireAction -> State VampireState -> State VampireState
transition (Action Bite) (State Alive) = State Vampire
transition (Action Kill) _ = State Dead

callback :: State VampireState -> State VampireState -> IO ()
callback _ (State Dead) = putStrLn "Dead!"
callback (State from) (State to) = putStrLn $ "transition from " ++ show from ++ " to " ++ show to 

main :: IO ()
main = do
  runFsm (State Alive) (Transition transition) (Callback callback) $ \ action -> do
    action Bite
    action Kill
  return ()

Main.hs

module Main where

import Fsm (Fsm(Fsm), input, evalFsm)


data State = Dead | Alive | Vampire deriving Show

data Action = Kill | Bite deriving Show


transition :: Action -> State -> State
transition Bite Alive = Vampire
transition Kill _ = Dead

callback :: State -> State -> IO ()
callback _ Dead = putStrLn "Dead!"
callback from to = putStrLn $ "transition from " ++ show from ++ " to " ++ show to 

main :: IO ()
main = do
  evalFsm (Fsm transition Alive callback) $ do 
    input Bite
    input Kill
  return ()