STM with time limit

This is basically a rehash of a useful Simon Marlow post to haskell-cafe, but with a few tweaks. It’s a useful way of wrapping an STM action with a timeout. In my case, I want to wait until some mutable state satisfies a predicate, and I want a timeout to fire if it takes too long. I hate thinking in microseconds, so there’s a helper type to improve that. And where Simon used a nested Maybe, I created some explicitly named constructors.

import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad

data TimeLimited a = Timeout | Result a deriving Show

data Timeout = TimeoutSecs Int
             | TimeoutMs Int

waitUntil :: TVar a -> (a -> Bool) -> Timeout -> IO (TimeLimited a)
waitUntil var pred timeout = do
  timer < - registerDelay $ case timeout of 
                             TimeoutSecs n -> 1000000 * n
                             TimeoutMs n -> 1000 * n
  let
      check_timeout = do 
        b < - readTVar timer
        if b then return Timeout else retry 
      check_t = do 
          m <- readTVar var
          when (not $ pred m) retry
          return $ Result m
  atomically $ check_timeout `orElse` check_t 

main = do
  tvar <- atomically $ newTVar 44
--  tvar <- atomically $ newTVar 41
  waitUntil tvar (>43) (TimeoutSecs 1) >>= print