20 files changed, 43 insertions, 31 deletions

diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
index 680b264f..fc3b6369 100644
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -21,6 +21,7 @@ import qualified GHC.Conc as GHC
 import Data.Time()
 import Data.Time.Clock
 import DPut
+import DebugTag
 
 
 data PerThread = PerThread
diff --git a/src/DPut.hs b/src/DPut.hs
index 6fd69040..38e532d0 100644
--- a/src/DPut.hs
+++ b/src/DPut.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module DPut where
 
 import Control.Monad.IO.Class
@@ -10,26 +12,10 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Debug.Trace
+import Data.Typeable
+import Data.Dynamic
 
--- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
-data DebugTag
-  = XAnnounce
-  | XBitTorrent
-  | XDHT
-  | XLan
-  | XMan
-  | XNetCrypto
-  | XNetCryptoOut
-  | XOnion
-  | XRoutes
-  | XPing
-  | XRefresh
-  | XJabber
-  | XMisc
-  | XNodeinfoSearch
-  | XUnexpected -- Used only for special anomalous errors that we didn't expect to happen.
-  | XUnused     -- Never commit code that uses XUnused.
-  deriving (Eq, Ord, Show, Read, Enum, Bounded)
+type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t)
 
 appName :: String
 appName = "toxmpp"
@@ -37,43 +23,50 @@ appName = "toxmpp"
 (<.>) :: String -> String -> String
 a <.> b = a ++ "." ++ b
 
-dput :: MonadIO m => DebugTag -> String -> m ()
+dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m ()
 dput tag msg = liftIO $ debugM (appName <.> show tag) msg
 
-dputB :: MonadIO m => DebugTag -> B.ByteString -> m ()
+dputB :: (MonadIO m, IsDebugTag tag) => tag -> B.ByteString -> m ()
 dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
 
 {-# NOINLINE verbosityMap #-}
-verbosityMap :: IORef (Map.Map DebugTag Bool)
+verbosityMap :: IORef (Map.Map TypeRep Dynamic)
 verbosityMap = unsafePerformIO $ newIORef (Map.empty)
 
 -- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO.
-tput :: Applicative m => DebugTag -> String -> m ()
+tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m ()
 tput tag msg =
   let mp = unsafePerformIO $ readIORef verbosityMap
-    in if fromMaybe True (Map.lookup tag mp)
+    in if maybe True (fromMaybe True . Map.lookup tag . flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp)
         then trace msg (pure ())
         else pure ()
 
 -- | like 'trace' but parameterized with 'DebugTag'
-dtrace :: DebugTag -> String -> a -> a
+dtrace :: forall a tag. IsDebugTag tag =>  tag -> String -> a -> a
 dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap
-                            in if fromMaybe True (Map.lookup tag mp)
+                            mp' :: Map.Map tag Bool
+                            mp' = maybe Map.empty (flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp)
+                            in if fromMaybe True (Map.lookup tag mp')
                                 then trace msg result
                                 else result
 
-setTagLevel :: Priority -> DebugTag -> IO ()
+setTagLevel :: forall tag. IsDebugTag tag => Priority -> tag -> IO ()
 setTagLevel level tag = do
     updateGlobalLogger (appName <.> show tag) (setLevel level)
-    modifyIORef verbosityMap (Map.insert tag (level <= DEBUG))
+    modifyIORef verbosityMap $ \mpByType -> do
+        case Map.lookup (typeOf tag) mpByType of
+            Nothing -> Map.insert (typeOf tag) (toDyn $ Map.fromList [(tag,(level <= DEBUG))]) mpByType
+            Just dyn -> let mpByTag :: Map.Map tag Bool
+                            mpByTag = fromDyn dyn Map.empty 
+                            in Map.insert (typeOf tag) (toDyn $ Map.insert tag (level <= DEBUG) mpByTag) mpByType
 
-setQuiet :: DebugTag -> IO ()
+setQuiet :: forall tag. IsDebugTag tag => tag -> IO ()
 setQuiet = setTagLevel WARNING
 
-setVerbose :: DebugTag -> IO ()
+setVerbose :: forall tag. IsDebugTag tag => tag -> IO ()
 setVerbose = setTagLevel DEBUG
 
-getVerbose :: DebugTag -> IO Bool
+getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool
 getVerbose tag = do
     logger <- getLogger (appName <.> show tag)
     case getLevel logger of
diff --git a/src/Data/PacketBuffer.hs b/src/Data/PacketBuffer.hs
index 343cb04e..17745664 100644
--- a/src/Data/PacketBuffer.hs
+++ b/src/Data/PacketBuffer.hs
@@ -19,6 +19,7 @@ module Data.PacketBuffer
 
 import Data.PacketQueue as Q
 import DPut
+import DebugTag
 
 import Control.Concurrent.STM
 import Control.Monad
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
index 3adfdc91..246463c0 100644
--- a/src/Network/Address.hs
+++ b/src/Network/Address.hs
@@ -130,6 +130,7 @@ import System.Locale    (defaultTimeLocale)
 #endif
 import System.Entropy
 import DPut
+import DebugTag
 
 -- import Paths_bittorrent (version)
 
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index c5b99234..573efcba 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -83,6 +83,7 @@ import Text.Read
 import System.Global6
 import Control.TriadCommittee
 import DPut
+import DebugTag
 
 newtype NodeId = NodeId ByteString
  deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
index 1a70a9c5..aad8a81e 100644
--- a/src/Network/Kademlia/Bootstrap.hs
+++ b/src/Network/Kademlia/Bootstrap.hs
@@ -32,6 +32,7 @@ import Data.Ord
 import System.Entropy
 import System.Timeout
 import DPut
+import DebugTag
 
 import qualified Data.Wrapper.PSQInt  as Int
          ;import Data.Wrapper.PSQInt  (pattern (:->))
diff --git a/src/Network/Lossless.hs b/src/Network/Lossless.hs
index 4d5521fd..861792ab 100644
--- a/src/Network/Lossless.hs
+++ b/src/Network/Lossless.hs
@@ -18,6 +18,7 @@ import System.IO.Error
 
 import Data.PacketBuffer as PB
 import DPut
+import DebugTag
 import Network.QueryResponse
 
 #ifdef THREAD_DEBUG
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index fdfbdbae..4e110ec3 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -38,6 +38,7 @@ import System.IO
 import System.IO.Error
 import System.Timeout
 import DPut
+import DebugTag
 
 -- | Three methods are required to implement a datagram based query\/response protocol.
 data TransportA err addr x y = Transport
diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs
index 2734f0cd..afa35675 100644
--- a/src/Network/StreamServer.hs
+++ b/src/Network/StreamServer.hs
@@ -44,6 +44,7 @@ import Control.Concurrent.MVar (newMVar)
 
 import Network.SocketLike
 import DPut
+import DebugTag
 
 data ServerHandle = ServerHandle Socket (Weak ThreadId)
 
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 88228c50..ddb22d50 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -61,6 +61,7 @@ import OnionRouter
 import Network.Tox.ContactInfo
 import Text.XXD
 import DPut
+import DebugTag
 import Network.Tox.Avahi
 import Network.Tox.Session
 import Network.SessionTransports
diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs
index 2323673a..b248c96f 100644
--- a/src/Network/Tox/AggregateSession.hs
+++ b/src/Network/Tox/AggregateSession.hs
@@ -41,6 +41,7 @@ import Connection                   (Status (..))
 import Crypto.Tox                   (PublicKey, toPublic)
 import Data.Wrapper.PSQInt          as PSQ
 import DPut
+import DebugTag
 import Network.QueryResponse
 import Network.Tox.Crypto.Transport (CryptoMessage (..), pattern KillPacket,
                                      pattern ONLINE, pattern PING,
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
index 387a6e47..e7cb48c1 100644
--- a/src/Network/Tox/ContactInfo.hs
+++ b/src/Network/Tox/ContactInfo.hs
@@ -15,6 +15,7 @@ import Network.Tox.DHT.Transport     as DHT
 import Network.Tox.NodeId            (id2key)
 import Network.Tox.Onion.Transport   as Onion
 import DPut
+import DebugTag
 
 newtype ContactInfo extra = ContactInfo
       -- | Map our toxid public key to an Account record.
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index bf01e1b5..94dde8e3 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -51,6 +51,7 @@ import qualified Data.IntMap.Strict as IntMap
 import Control.Concurrent.Supply
 import Data.InOrOut
 import DPut
+import DebugTag
 import Text.Printf
 import Data.Bool
 import Network.Tox.Handshake
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 84929e63..555164f2 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -87,6 +87,7 @@ import Data.Text.Encoding as T
 import Data.Serialize as S
 import Control.Arrow
 import DPut
+import DebugTag
 import Data.PacketBuffer as PB
 
 showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index b1db9044..d7f05dbc 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -40,6 +40,7 @@ import Data.Maybe
 import Data.Serialize (Serialize)
 import Data.Word
 import DPut
+import DebugTag
 
 data TransactionId = TransactionId
  { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
diff --git a/src/Network/Tox/Handshake.hs b/src/Network/Tox/Handshake.hs
index 0ca99fe2..6df9edab 100644
--- a/src/Network/Tox/Handshake.hs
+++ b/src/Network/Tox/Handshake.hs
@@ -23,6 +23,7 @@ import Control.Concurrent
 import GHC.Conc           (labelThread)
 #endif
 import DPut
+import DebugTag
 
 
 anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 80a6ae3a..0d8a9151 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -38,6 +38,7 @@ import Data.IP
 import Data.Maybe
 import Data.Functor.Identity
 import DPut
+import DebugTag
 
 type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
 type Message = OnionMessage Identity
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 7ed9702a..10bd5a44 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -82,6 +82,7 @@ import Network.Socket
 import qualified Text.ParserCombinators.ReadP as RP
 import Data.Hashable
 import DPut
+import DebugTag
 
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs
index 968b3503..18e17fb6 100644
--- a/src/Network/Tox/Session.hs
+++ b/src/Network/Tox/Session.hs
@@ -20,6 +20,7 @@ import Crypto.Tox
 import Data.PacketBuffer            (PacketInboundEvent (..))
 import Data.Tox.Message
 import DPut
+import DebugTag
 import Network.Lossless
 import Network.QueryResponse
 import Network.SessionTransports
diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs
index e89471c2..01d222bf 100644
--- a/src/Network/UPNP.hs
+++ b/src/Network/UPNP.hs
@@ -6,6 +6,7 @@ import Network.Socket
 import System.Directory
 import System.Process  as Process
 import DPut
+import DebugTag
 
 protocols :: SocketType -> [String]
 protocols Stream   = ["tcp"]