[Haskell-cafe] Interruptable event loop

[Mitar]

Hi!

I have X11 code which looks something like the following. The problem
is that TimerInterrupt gets sometimes thrown in a way that it kills
the whole main thread. Probably it gets thrown in the middle of some
nested function which unblocked exceptions. I found:

http://hackage.haskell.org/trac/ghc/ticket/1036#comment:4

but this is not yet in GHC stable version. Is there some workaround
for this? Because I have problems compiling current Haskell platform
with GHC head.

currentThread <- myThreadId
_ <- forkIO $ timer currentThread
block $ run display

run display = do
  ...
  allocaXEvent $ \event -> do
    interrupted <- catch (unblock $ nextEvent' display event >> return
False) (\(_ :: TimerInterrupt) -> return True)
  ...
  run display

-- A version of nextEvent that does not block in foreign calls
nextEvent' :: Display -> XEventPtr -> IO ()
nextEvent' d p = do
 pend <- pending d
 if pend /= 0
   then nextEvent d p
   else do
     threadWaitRead (fromIntegral . connectionNumber $ d)
     nextEvent' d p

data TimerInterrupt = TimerInterrupt deriving (Show, Typeable)
instance Exception TimerInterrupt

timer :: ThreadId -> IO ()
timer t = do
  threadDelay redrawInterval
  throwTo t TimerInterrupt
  timer t


Mitar