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.<\/p>\n
\r\nimport Control.Concurrent.STM\r\nimport Control.Concurrent\r\nimport Control.Monad\r\n\r\ndata TimeLimited a = Timeout | Result a deriving Show\r\n\r\ndata Timeout = TimeoutSecs Int\r\n | TimeoutMs Int\r\n\r\nwaitUntil :: TVar a -> (a -> Bool) -> Timeout -> IO (TimeLimited a)\r\nwaitUntil var pred timeout = do\r\n timer < - registerDelay $ case timeout of \r\n TimeoutSecs n -> 1000000 * n\r\n TimeoutMs n -> 1000 * n\r\n let\r\n check_timeout = do \r\n b < - readTVar timer\r\n if b then return Timeout else retry \r\n check_t = do \r\n m <- readTVar var\r\n when (not $ pred m) retry\r\n return $ Result m\r\n atomically $ check_timeout `orElse` check_t \r\n\r\nmain = do\r\n tvar <- atomically $ newTVar 44\r\n-- tvar <- atomically $ newTVar 41\r\n waitUntil tvar (>43) (TimeoutSecs 1) >>= print\r\n<\/pre>\n","protected":false},"excerpt":{"rendered":"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 […]<\/p>\n","protected":false},"author":1,"featured_media":0,"comment_status":"open","ping_status":"closed","sticky":false,"template":"","format":"standard","meta":{"footnotes":""},"categories":[1],"tags":[],"class_list":["post-402","post","type-post","status-publish","format-standard","hentry","category-general"],"_links":{"self":[{"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/posts\/402","targetHints":{"allow":["GET"]}}],"collection":[{"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/posts"}],"about":[{"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/types\/post"}],"author":[{"embeddable":true,"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/users\/1"}],"replies":[{"embeddable":true,"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/comments?post=402"}],"version-history":[{"count":2,"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/posts\/402\/revisions"}],"predecessor-version":[{"id":404,"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/posts\/402\/revisions\/404"}],"wp:attachment":[{"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/media?parent=402"}],"wp:term":[{"taxonomy":"category","embeddable":true,"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/categories?post=402"},{"taxonomy":"post_tag","embeddable":true,"href":"https:\/\/www.nobugs.org\/blog\/wp-json\/wp\/v2\/tags?post=402"}],"curies":[{"name":"wp","href":"https:\/\/api.w.org\/{rel}","templated":true}]}}