Bug fix to Announcer.

1 files changed, 41 insertions, 0 deletions

diff --git a/InterruptibleDelay.hs b/InterruptibleDelay.hs
new file mode 100644
index 00000000..d59ec8ef
--- /dev/null
+++ b/InterruptibleDelay.hs
@@ -0,0 +1,41 @@
+module InterruptibleDelay where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Exception ({-evaluate,-}handle,ErrorCall(..))
+import Data.Time.Clock (NominalDiffTime)
+
+type Microseconds = Int
+
+microseconds :: NominalDiffTime -> Microseconds
+microseconds d = round $ 1000000 * d
+
+data InterruptibleDelay = InterruptibleDelay
+        { delayThread :: MVar ThreadId
+        }
+
+interruptibleDelay :: IO InterruptibleDelay
+interruptibleDelay = do
+    fmap InterruptibleDelay newEmptyMVar
+
+startDelay :: InterruptibleDelay -> Microseconds -> IO Bool
+startDelay d interval = do
+    thread <- myThreadId
+    handle (\(ErrorCall _)-> do
+                debugNoise $ "delay interrupted"
+                return False) $ do 
+        putMVar (delayThread d) thread
+        threadDelay interval
+        void $ takeMVar (delayThread d)
+        return True
+
+  where debugNoise str = return ()
+
+
+interruptDelay :: InterruptibleDelay -> IO ()
+interruptDelay d = do
+    mthread <- do
+        tryTakeMVar (delayThread d)
+    flip (maybe $ return ()) mthread $ \thread -> do
+    throwTo thread (ErrorCall "Interrupted delay")
+