From 2dfb3b4f514251b7dde082cbca5d8ad358ee479d Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 14:19:35 -0400 Subject: Use dput-hslogger instead of internal DPut --- dht/dht-client.cabal | 8 +++--- dht/src/DPut.hs | 75 ---------------------------------------------------- 2 files changed, 3 insertions(+), 80 deletions(-) delete mode 100644 dht/src/DPut.hs diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal index 7efc2392..1cc93e3d 100644 --- a/dht/dht-client.cabal +++ b/dht/dht-client.cabal @@ -70,9 +70,7 @@ library , RecordWildCards , NondecreasingIndentation hs-source-dirs: src, ., Presence - exposed-modules: DPut - DebugTag - Network.SocketLike + exposed-modules: Network.SocketLike Data.Digest.CRC32C Data.Bits.ByteString Data.TableMethods @@ -212,7 +210,7 @@ library , exceptions , hinotify , avahi >= 0.2.0 - , hslogger + , dput-hslogger , word64-map , network-addr , tox-crypto @@ -238,7 +236,7 @@ library Build-depends: network >= 2.4 && < 2.6 - other-modules: Paths_dht_client + other-modules: Paths_dht_client, DebugTag C-sources: Presence/monitortty.c diff --git a/dht/src/DPut.hs b/dht/src/DPut.hs deleted file mode 100644 index 38e532d0..00000000 --- a/dht/src/DPut.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -module DPut where - -import Control.Monad.IO.Class -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import System.Log.Logger -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 - -type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t) - -appName :: String -appName = "toxmpp" - -(<.>) :: String -> String -> String -a <.> b = a ++ "." ++ b - -dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m () -dput tag msg = liftIO $ debugM (appName <.> show tag) msg - -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 TypeRep Dynamic) -verbosityMap = unsafePerformIO $ newIORef (Map.empty) - --- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO. -tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m () -tput tag msg = - let mp = unsafePerformIO $ readIORef verbosityMap - 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 :: forall a tag. IsDebugTag tag => tag -> String -> a -> a -dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap - 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 :: forall tag. IsDebugTag tag => Priority -> tag -> IO () -setTagLevel level tag = do - updateGlobalLogger (appName <.> show tag) (setLevel level) - 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 :: forall tag. IsDebugTag tag => tag -> IO () -setQuiet = setTagLevel WARNING - -setVerbose :: forall tag. IsDebugTag tag => tag -> IO () -setVerbose = setTagLevel DEBUG - -getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool -getVerbose tag = do - logger <- getLogger (appName <.> show tag) - case getLevel logger of - Just p | p <= DEBUG -> return True - _ -> return False - -- cgit v1.2.3