[Haskell-cafe] Writing a generic event handler

11 Feb 2009

      Hi Haskell Cafe,

I'm interested in writing some events and event handlers in Haskell.  I
already have a Loop data structure, and I intend to use it for this purpose:

-- Create event
tEvent <- newLoop (return ())

-- Register event handlers
tHandler1 <- newLoop (putStrLn "Handler1")
tHandler2 <- newLoop (putStrLn "Handler2")
splice tEvent tHandler1
splice tEvent tHandler2

-- Fire event
action <- doLoop tEvent
action

doLoop :: Monad m => TVar (Loop (m ())) -> STM (m ())
doLoop tLoop = do
   aLoop <- readAsList tLoop
   return $ sequence_ aLoop

My question is: Is it possible to write a generic doLoop that works over
arbitrary functions?

For instance the following code wouldn't work because the event provides one
argument and the handler takes one argument:

-- Create event
tEvent <- newLoop (\x -> return ())

-- Register event handlers
tHandler1 <- newLoop (\x -> putStrLn ("Handler1" ++ show x))
tHandler2 <- newLoop (\x -> putStrLn ("Handler2" ++ show x))
splice tEvent tHandler1
splice tEvent tHandler2

-- Fire event
action <- doLoop tEvent
action 123

Thanks,

-John

Full source code for Loop type:

module Fx.STM.Loop where

import Control.Monad
import Fx.STM.Util
import GHC.Conc
import System.IO.Unsafe

-- Transactional loop.  A loop is a circular link list.
data Loop a
   = ItemLink
      { item :: a
      , prev :: TVar (Loop a)
      , next :: TVar (Loop a)
      }

-- Create a new empty transactional loop.
newLoop :: a -> STM (TVar (Loop a))
newLoop item = do
   tLoop <- newTVar undefined
   writeTVar tLoop (ItemLink item tLoop tLoop)
   return tLoop

-- Splice two transactional loops.  This will join two loops if they were
-- originally separate, or split a single loop if the links were originally
-- part of the same loop.  No change occurs if the two links are identical.
splice :: TVar (Loop a) -> TVar (Loop a) -> STM ()
splice tLink0 tLink1 = do
   aLink0 <- readTVar tLink0
   aLink1 <- readTVar tLink1
   let tLink0Prev = prev aLink0
   let tLink1Prev = prev aLink1
   writeTVar tLink0 aLink0 { prev = tLink1Prev }
   writeTVar tLink1 aLink1 { prev = tLink0Prev }
   aLink0Prev <- readTVar tLink0Prev
   aLink1Prev <- readTVar tLink1Prev
   writeTVar tLink0Prev aLink0Prev { next = tLink1 }
   writeTVar tLink1Prev aLink1Prev { next = tLink0 }
   return ()

-- Unlink a single link from a transactional loop.
unlink :: TVar (Loop a) -> STM ()
unlink tLink = do
   (ItemLink item tLinkPrev tLinkNext) <- readTVar tLink
   aLinkPrev <- readTVar tLinkPrev
   writeTVar tLinkPrev aLinkPrev { next = tLinkNext }
   aLinkNext <- readTVar tLinkNext
   writeTVar tLinkNext aLinkNext { prev = tLinkPrev }
   writeTVar tLink (ItemLink item tLink tLink)
   return ()

-- Read the length of the loop.
readLength :: TVar (Loop a) -> STM Int
readLength tLink = do
   list <- readAsList tLink
   return $ length list

readLinks :: TVar (Loop a) -> STM [TVar (Loop a)]
readLinks tLink = readLinksUntil tLink tLink

readLinksUntil :: TVar (Loop a) -> TVar (Loop a) -> STM [TVar (Loop a)]
readLinksUntil tLink tLinkEnd = do
   (ItemLink _ tLinkPrev tLinkNext) <- readTVar tLink
   return []
   if tLinkNext == tLinkEnd
      then return [tLink]
      else do
         tail <- readLinksUntil tLinkNext tLinkEnd
         return $ tLink:tail

-- Read the elements of the loop as a list starting from tLink.
readAsList :: TVar (Loop a) -> STM [a]
readAsList tLink = readAsListUntil tLink tLink

-- Read the elements of the loop as a list starting from tLink
-- and terminating non-inclusively at tLinkEnd.
readAsListUntil :: TVar (Loop a) -> TVar (Loop a) -> STM [a]
readAsListUntil tLink tLinkEnd = do
   (ItemLink item tLinkPrev tLinkNext) <- readTVar tLink
   if tLinkNext == tLinkEnd
      then return [item]
      else do
         tail <- readAsListUntil tLinkNext tLinkEnd
         return $ item:tail

-- Create a new loop from a list.
newFromList :: [a] -> STM (TVar (Loop a))
newFromList [item] = newLoop item
newFromList (item:items) = do
   tLink <- newLoop item
   tLinkRest <- newFromList items
   splice tLink tLinkRest
   return tLink

doLoop :: Monad m => TVar (Loop (m ())) -> STM (m ())
doLoop tLoop = do
   aLoop <- readAsList tLoop
   return $ sequence_ aLoop

[Haskell-cafe] Writing a generic event handler

John Ky