From cb853466ae8a5cffccb0f74da7aa7d2d85f83959 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Tue, 31 Oct 2017 22:09:49 -0400
Subject: Bug fix to Announcer.

---
 InterruptibleDelay.hs | 41 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 41 insertions(+)
 create mode 100644 InterruptibleDelay.hs

(limited to 'InterruptibleDelay.hs')

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")
+
-- 
cgit v1.2.3