Event System in Haskell

events.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad.State
import Data.Text
import Data.Monoid
import qualified Data.Map as M
import Control.Monad

-- All events, along with a payload, in our system.
data Event
  = FunctionCalled Text
  | OrderPlaced Order
    deriving (Show, Eq)

-- A theoretical "Order"
data Order = Order
  { orderId :: Int
  , orderCents :: Int
  } deriving (Show, Eq)

-- The name of an event handler; this will be used for {de}registering handlers.
type Name = Text

-- The abstract type of a handler: An action run on an Event in some context.
type Handler m a = Event -> m a

-- A map from listener names to event handlers.
type ListenerMap m a = M.Map Name (Handler m a)

-- An "evented" context for actions.
-- Has a ListenerMap as State, which it will use to call handlers
-- as events flow into the system.
type Evented m a b = StateT (ListenerMap m a) m b

-- Register a new handler with the given name.
register :: Monad m => Name -> Handler m a -> Evented m a ()
register name handler = modify (M.insert name handler)

-- Deregister the handler with a given name.
deregister :: Monad m => Name -> Evented m a ()
deregister name = modify (M.delete name)

-- Fire an event in our system, collecting all results from handlers.
-- Result is a mapping from listener -> handler result
fire :: Monad m => Event -> Evented m a (M.Map Name a)
fire e = get >>= traverse (\handler -> lift (handler e))

-- Fire an event, discarding any results.
fire_ :: Monad m => Event -> Evented m a ()
fire_ e = void (fire e)

-- A simple handler that logs information about our events.
loggingHandler :: Event -> IO ()
loggingHandler (FunctionCalled text) = print text
loggingHandler (OrderPlaced (Order id_ cents_))
  = putStrLn ("Order: " <> show id_ <> " for " <> show cents_ <> " cents placed.")

-- Our initial handler mapping. Contains a single handler that logs events.
handlers :: M.Map Text (Event -> IO ())
handlers = M.fromList
  [ ("logger", loggingHandler)
  ]

-- Theoretical Evented IO operation that places an Order and fires an event.
placeOrder :: Order -> Evented IO a ()
placeOrder order = do
  -- do some database stuff...
  fire_ (OrderPlaced order)

-- A very basic program that goes through some "evented" processes.
executeProgram = do
  placeOrder (Order 1 1000)
  deregister "logger"
  placeOrder (Order 2 3000)
  register "logger" loggingHandler
  placeOrder (Order 3 9000)

-- Run the program.
main :: IO ()
main = void (runStateT executeProgram handlers)