blob: 38e532d0668bc6d487e520ff165a32ee9240eabf (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
{-# 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
|
