1 files changed, 24 insertions, 31 deletions

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