summaryrefslogtreecommitdiff
path: root/dput-hslogger
diff options
context:
space:
mode:
Diffstat (limited to 'dput-hslogger')
-rw-r--r--dput-hslogger/CHANGELOG.md5
-rw-r--r--dput-hslogger/LICENSE30
-rw-r--r--dput-hslogger/Setup.hs2
-rw-r--r--dput-hslogger/dput-hslogger.cabal24
-rw-r--r--dput-hslogger/src/DPut.hs75
5 files changed, 136 insertions, 0 deletions
diff --git a/dput-hslogger/CHANGELOG.md b/dput-hslogger/CHANGELOG.md
new file mode 100644
index 00000000..8626ce35
--- /dev/null
+++ b/dput-hslogger/CHANGELOG.md
@@ -0,0 +1,5 @@
1# Revision history for dput-hslogger
2
3## 0.1.0.0 -- YYYY-mm-dd
4
5* First version. Released on an unsuspecting world.
diff --git a/dput-hslogger/LICENSE b/dput-hslogger/LICENSE
new file mode 100644
index 00000000..a97490ef
--- /dev/null
+++ b/dput-hslogger/LICENSE
@@ -0,0 +1,30 @@
1Copyright (c) 2018, James Crayne
2
3All rights reserved.
4
5Redistribution and use in source and binary forms, with or without
6modification, are permitted provided that the following conditions are met:
7
8 * Redistributions of source code must retain the above copyright
9 notice, this list of conditions and the following disclaimer.
10
11 * Redistributions in binary form must reproduce the above
12 copyright notice, this list of conditions and the following
13 disclaimer in the documentation and/or other materials provided
14 with the distribution.
15
16 * Neither the name of James Crayne nor the names of other
17 contributors may be used to endorse or promote products derived
18 from this software without specific prior written permission.
19
20THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/dput-hslogger/Setup.hs b/dput-hslogger/Setup.hs
new file mode 100644
index 00000000..9a994af6
--- /dev/null
+++ b/dput-hslogger/Setup.hs
@@ -0,0 +1,2 @@
1import Distribution.Simple
2main = defaultMain
diff --git a/dput-hslogger/dput-hslogger.cabal b/dput-hslogger/dput-hslogger.cabal
new file mode 100644
index 00000000..0ddb75ba
--- /dev/null
+++ b/dput-hslogger/dput-hslogger.cabal
@@ -0,0 +1,24 @@
1-- Initial dput-hslogger.cabal generated by cabal init. For further
2-- documentation, see http://haskell.org/cabal/users-guide/
3
4name: dput-hslogger
5version: 0.1.0.0
6synopsis: Quick and dirty debug prints indexed by user Enum type.
7-- description:
8license: BSD3
9license-file: LICENSE
10author: James Crayne
11maintainer: jim.crayne@gmail.com
12-- copyright:
13category: Development
14build-type: Simple
15extra-source-files: CHANGELOG.md
16cabal-version: >=1.10
17
18library
19 exposed-modules: DPut
20 -- other-modules:
21 other-extensions: ConstraintKinds, ScopedTypeVariables
22 build-depends: base -any, containers -any, bytestring -any, text -any, hslogger -any
23 hs-source-dirs: src
24 default-language: Haskell2010
diff --git a/dput-hslogger/src/DPut.hs b/dput-hslogger/src/DPut.hs
new file mode 100644
index 00000000..38e532d0
--- /dev/null
+++ b/dput-hslogger/src/DPut.hs
@@ -0,0 +1,75 @@
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3module DPut where
4
5import Control.Monad.IO.Class
6import qualified Data.Map.Strict as Map
7import Data.Maybe
8import Data.IORef
9import System.IO.Unsafe (unsafePerformIO)
10import System.Log.Logger
11import qualified Data.ByteString.Char8 as B
12import qualified Data.Text as T
13import qualified Data.Text.Encoding as T
14import Debug.Trace
15import Data.Typeable
16import Data.Dynamic
17
18type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t)
19
20appName :: String
21appName = "toxmpp"
22
23(<.>) :: String -> String -> String
24a <.> b = a ++ "." ++ b
25
26dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m ()
27dput tag msg = liftIO $ debugM (appName <.> show tag) msg
28
29dputB :: (MonadIO m, IsDebugTag tag) => tag -> B.ByteString -> m ()
30dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
31
32{-# NOINLINE verbosityMap #-}
33verbosityMap :: IORef (Map.Map TypeRep Dynamic)
34verbosityMap = unsafePerformIO $ newIORef (Map.empty)
35
36-- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO.
37tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m ()
38tput 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'
45dtrace :: forall a tag. IsDebugTag tag => tag -> String -> a -> a
46dtrace 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
53setTagLevel :: forall tag. IsDebugTag tag => Priority -> tag -> IO ()
54setTagLevel 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
63setQuiet :: forall tag. IsDebugTag tag => tag -> IO ()
64setQuiet = setTagLevel WARNING
65
66setVerbose :: forall tag. IsDebugTag tag => tag -> IO ()
67setVerbose = setTagLevel DEBUG
68
69getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool
70getVerbose tag = do
71 logger <- getLogger (appName <.> show tag)
72 case getLevel logger of
73 Just p | p <= DEBUG -> return True
74 _ -> return False
75