From 058ccb22f43e9053fa37ed719d31c72dd6dac27c Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 23 Jan 2017 22:32:17 -0500
Subject: Added thread-debug flag and "threads" command.

---
 src/Network/KRPC/Manager.hs | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

(limited to 'src/Network/KRPC')

diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 4852eb38..22d111e2 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -7,6 +7,7 @@
 --
 --   Normally, you don't need to import this module.
 --
+{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FlexibleContexts       #-}
@@ -41,8 +42,12 @@ module Network.KRPC.Manager
        ) where
 
 import Control.Applicative
-import Control.Concurrent
-import Control.Concurrent.Lifted (fork)
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import GHC.Conc (labelThread)
+import Control.Concurrent.Lifted
+#endif
 import Control.Exception hiding (Handler)
 import qualified Control.Exception.Lifted as E (Handler (..))
 import Control.Exception.Lifted as Lifted (catches, finally)
@@ -432,6 +437,7 @@ dispatchHandler q @ KQuery {..} addr = do
 --
 handleQuery :: MonadKRPC h m => BValue -> KQuery -> SockAddr -> m ()
 handleQuery raw q addr = void $ fork $ do
+  myThreadId >>= liftIO . flip labelThread "KRPC.handleQuery"
   Manager {..} <- getManager
   res <- dispatchHandler q addr
   let resbe = either toBEncode toBEncode res
@@ -481,6 +487,7 @@ listen :: MonadKRPC h m => m ()
 listen = do
   Manager {..} <- getManager
   tid <- fork $ do
+    myThreadId >>= liftIO . flip labelThread "KRPC.listen"
     listener `Lifted.finally`
       liftIO (takeMVar listenerThread)
   liftIO $ putMVar listenerThread tid
-- 
cgit v1.2.3