diff options
author | James Crayne <jim.crayne@gmail.com> | 2018-11-04 03:43:33 -0500 |
---|---|---|
committer | James Crayne <jim.crayne@gmail.com> | 2018-11-04 03:43:33 -0500 |
commit | c0910442bb7258398a6717400c1054aa177faca1 (patch) | |
tree | 5ed4af4a34d80705893ab21a982079b3ca2cedb4 /src/DPut.hs | |
parent | 5f5aa818f8484570349e75a061d7b37cc9fe826a (diff) |
Moved DPut module to separate library
Diffstat (limited to 'src/DPut.hs')
-rw-r--r-- | src/DPut.hs | 75 |
1 files changed, 0 insertions, 75 deletions
diff --git a/src/DPut.hs b/src/DPut.hs deleted file mode 100644 index 38e532d0..00000000 --- a/src/DPut.hs +++ /dev/null | |||
@@ -1,75 +0,0 @@ | |||
1 | {-# LANGUAGE ConstraintKinds #-} | ||
2 | {-# LANGUAGE ScopedTypeVariables #-} | ||
3 | module DPut where | ||
4 | |||
5 | import Control.Monad.IO.Class | ||
6 | import qualified Data.Map.Strict as Map | ||
7 | import Data.Maybe | ||
8 | import Data.IORef | ||
9 | import System.IO.Unsafe (unsafePerformIO) | ||
10 | import System.Log.Logger | ||
11 | import qualified Data.ByteString.Char8 as B | ||
12 | import qualified Data.Text as T | ||
13 | import qualified Data.Text.Encoding as T | ||
14 | import Debug.Trace | ||
15 | import Data.Typeable | ||
16 | import Data.Dynamic | ||
17 | |||
18 | type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t) | ||
19 | |||
20 | appName :: String | ||
21 | appName = "toxmpp" | ||
22 | |||
23 | (<.>) :: String -> String -> String | ||
24 | a <.> b = a ++ "." ++ b | ||
25 | |||
26 | dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m () | ||
27 | dput tag msg = liftIO $ debugM (appName <.> show tag) msg | ||
28 | |||
29 | dputB :: (MonadIO m, IsDebugTag tag) => tag -> B.ByteString -> m () | ||
30 | dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg) | ||
31 | |||
32 | {-# NOINLINE verbosityMap #-} | ||
33 | verbosityMap :: IORef (Map.Map TypeRep Dynamic) | ||
34 | verbosityMap = unsafePerformIO $ newIORef (Map.empty) | ||
35 | |||
36 | -- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO. | ||
37 | tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m () | ||
38 | tput tag msg = | ||
39 | let mp = unsafePerformIO $ readIORef verbosityMap | ||
40 | in if maybe True (fromMaybe True . Map.lookup tag . flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) | ||
41 | then trace msg (pure ()) | ||
42 | else pure () | ||
43 | |||
44 | -- | like 'trace' but parameterized with 'DebugTag' | ||
45 | dtrace :: forall a tag. IsDebugTag tag => tag -> String -> a -> a | ||
46 | dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap | ||
47 | mp' :: Map.Map tag Bool | ||
48 | mp' = maybe Map.empty (flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) | ||
49 | in if fromMaybe True (Map.lookup tag mp') | ||
50 | then trace msg result | ||
51 | else result | ||
52 | |||
53 | setTagLevel :: forall tag. IsDebugTag tag => Priority -> tag -> IO () | ||
54 | setTagLevel level tag = do | ||
55 | updateGlobalLogger (appName <.> show tag) (setLevel level) | ||
56 | modifyIORef verbosityMap $ \mpByType -> do | ||
57 | case Map.lookup (typeOf tag) mpByType of | ||
58 | Nothing -> Map.insert (typeOf tag) (toDyn $ Map.fromList [(tag,(level <= DEBUG))]) mpByType | ||
59 | Just dyn -> let mpByTag :: Map.Map tag Bool | ||
60 | mpByTag = fromDyn dyn Map.empty | ||
61 | in Map.insert (typeOf tag) (toDyn $ Map.insert tag (level <= DEBUG) mpByTag) mpByType | ||
62 | |||
63 | setQuiet :: forall tag. IsDebugTag tag => tag -> IO () | ||
64 | setQuiet = setTagLevel WARNING | ||
65 | |||
66 | setVerbose :: forall tag. IsDebugTag tag => tag -> IO () | ||
67 | setVerbose = setTagLevel DEBUG | ||
68 | |||
69 | getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool | ||
70 | getVerbose tag = do | ||
71 | logger <- getLogger (appName <.> show tag) | ||
72 | case getLevel logger of | ||
73 | Just p | p <= DEBUG -> return True | ||
74 | _ -> return False | ||
75 | |||