From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- dput-hslogger/CHANGELOG.md | 5 +++ dput-hslogger/LICENSE | 30 ++++++++++++++++ dput-hslogger/Setup.hs | 2 ++ dput-hslogger/dput-hslogger.cabal | 24 +++++++++++++ dput-hslogger/src/DPut.hs | 75 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 136 insertions(+) create mode 100644 dput-hslogger/CHANGELOG.md create mode 100644 dput-hslogger/LICENSE create mode 100644 dput-hslogger/Setup.hs create mode 100644 dput-hslogger/dput-hslogger.cabal create mode 100644 dput-hslogger/src/DPut.hs (limited to 'dput-hslogger') 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 @@ +# Revision history for dput-hslogger + +## 0.1.0.0 -- YYYY-mm-dd + +* 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 @@ +Copyright (c) 2018, James Crayne + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James Crayne nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF 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 @@ +import Distribution.Simple +main = 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 @@ +-- Initial dput-hslogger.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: dput-hslogger +version: 0.1.0.0 +synopsis: Quick and dirty debug prints indexed by user Enum type. +-- description: +license: BSD3 +license-file: LICENSE +author: James Crayne +maintainer: jim.crayne@gmail.com +-- copyright: +category: Development +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + exposed-modules: DPut + -- other-modules: + other-extensions: ConstraintKinds, ScopedTypeVariables + build-depends: base -any, containers -any, bytestring -any, text -any, hslogger -any + hs-source-dirs: src + 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 @@ +{-# 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