packages feed

logging (empty) → 1.0.0

raw patch · 5 files changed

+290/−0 lines, 5 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, fast-logger, hspec, lifted-base, logging, monad-control, monad-logger, old-locale, text, thyme, transformers, unix, vector-space

Files

+ Control/Logging.hs view
@@ -0,0 +1,175 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++module Control.Logging+    ( log+    , warn+    , debug+    , errorL+    , traceL+    , traceShowL+    , timedLog+    , timedLog'+    , timedDebug+    , timedDebug'+    , withStdoutLogging+    , withStderrLogging+    , flushLog+    , setDebugLevel+    , setLogFormat+    ) where++import Control.Exception.Lifted+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Control+import Data.AffineSpace+import Data.IORef+import Data.Monoid+import Data.Text as T+import Data.Thyme+import Debug.Trace+import Prelude hiding (log)+import System.IO.Unsafe+import System.Locale+import System.Log.FastLogger++logLevel :: IORef LogLevel+{-# NOINLINE logLevel #-}+logLevel = unsafePerformIO $ newIORef LevelDebug++-- | Set the verbosity level.  Messages at our higher than this level are+--   displayed.  It defaults to 'LevelDebug'.+setDebugLevel :: LogLevel -> IO ()+setDebugLevel = atomicWriteIORef logLevel++logSet :: IORef LoggerSet+{-# NOINLINE logSet #-}+logSet = unsafePerformIO $+    newIORef (error "Must call withStdoutLogging or withStderrLogging")++logFormat :: IORef String+{-# NOINLINE logFormat #-}+logFormat = unsafePerformIO $ newIORef "%Y %b-%d %H:%M:%S%Q"++-- | Set the format used for log timestamps.+setLogFormat :: String -> IO ()+setLogFormat = atomicWriteIORef logFormat++logger :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> IO ()+logger _loc !src !lvl str = do+    maxLvl <- readIORef logLevel+    when (lvl >= maxLvl) $ do+        now <- getCurrentTime+        fmt <- readIORef logFormat+        let stamp = formatTime defaultTimeLocale fmt now+        set <- readIORef logSet+        pushLogStr set+            $ toLogStr (stamp ++ " " ++ renderLevel lvl+                              ++ " " ++ renderSource src)+            <> toLogStr str+            <> toLogStr (pack "\n")+  where+    renderSource :: Text -> String+    renderSource txt+        | T.null txt = ""+        | otherwise  = unpack txt ++ ": "++    renderLevel LevelDebug = "[DEBUG]"+    renderLevel LevelInfo  = "[INFO]"+    renderLevel LevelWarn  = "[WARN]"+    renderLevel LevelError = "[ERROR]"+    renderLevel (LevelOther txt) = "[" ++ unpack txt ++ "]"++-- | This function, or 'withStderrLogging', must be wrapped around whatever+--   region of your application intends to use logging.  Typically it would be+--   wrapped around the body of 'main'.+withStdoutLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a+withStdoutLogging f = do+    liftIO $ do+        set <- newStdoutLoggerSet defaultBufSize+        atomicWriteIORef logSet set+    f `finally` flushLog++withStderrLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a+withStderrLogging f = do+    liftIO $ do+        set <- newStderrLoggerSet defaultBufSize+        atomicWriteIORef logSet set+    f `finally` flushLog++flushLog :: MonadIO m => m ()+flushLog = liftIO $ do+    set <- readIORef logSet+    flushLogStr set++instance MonadLogger IO where+    monadLoggerLog = logger++-- | Synonym for 'Control.Monad.Logger.logInfoN'.  This module provides a+--   'MonadLogger' instance for IO, so this function can be used directly in+--   IO.  The only requirement is that you must surround the body of your+--   @main@ function with a call to 'withStdoutLogging' or+--   'withStderrLogging', to ensure that all logging buffers are properly+--   flushed on exit.+log :: MonadLogger m => Text -> m ()+log = logInfoN++debug :: MonadLogger m => Text -> m ()+debug = logDebugN++warn :: MonadLogger m => Text -> m ()+warn = logWarnN++-- | A logging variant of 'error' which uses 'unsafePerformIO' to output a log+--   message before calling 'error'.+errorL :: Text -> a+errorL str = error (unsafePerformIO (logErrorN str) `seq` unpack str)++traceL :: Text -> a -> a+traceL str = trace (unsafePerformIO (logDebugN str) `seq` unpack str)++traceShowL :: Show a => a -> a1 -> a1+traceShowL x =+    let s = show x+    in trace (unsafePerformIO (logDebugN (pack s)) `seq` s)++doTimedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+         => (Text -> m ()) -> Bool -> Text -> m () -> m ()+doTimedLog logf wrapped msg f = do+    start <- liftIO getCurrentTime+    when wrapped $ logf $ msg <> "..."+    f `catch` \e -> do+        let str = show (e :: SomeException)+        wrapup start $ pack $+            if wrapped+            then "...FAIL (" ++ str ++ ")"+            else " (FAIL: " ++ str ++ ")"+        throwIO e+    wrapup start $ if wrapped then "...done" else ""+  where+    wrapup start m = do+        end <- liftIO getCurrentTime+        logf $ msg <> m <> " [" <> pack (show (end .-. start)) <> "]"++-- | Output a logging message both before an action begins, and after it ends,+--   reporting the total length of time.  If an exception occurred, it is also+--   reported.+timedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+         => Text -> m () -> m ()+timedLog = doTimedLog log True++-- | Like 'timedLog', except that it does only logs when the action has+--   completed or faileda.+timedLog' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+          => Text -> m () -> m ()+timedLog' = doTimedLog log False++-- | A debug variant of 'timedLog'.+timedDebug :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+           => Text -> m () -> m ()+timedDebug = doTimedLog debug True++timedDebug' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+            => Text -> m () -> m ()+timedDebug' = doTimedLog debug False
+ LICENSE view
@@ -0,0 +1,19 @@+opyright (c) 2014 John Wiegley++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ logging.cabal view
@@ -0,0 +1,73 @@+Name:                logging+Version:             1.0.0+Synopsis:            Simplified logging in IO for application writers.+License-file:        LICENSE+License:             MIT+Author:              John Wiegley+Maintainer:          johnw@newartisans.com+Build-Type:          Simple+Cabal-Version:       >=1.10+Category:            System+Description:+  @logging@ is a wrapper around @monad-logger@ and @fast-logger@ which makes+  it easy to log from any 'MonadLogger' environment, or from 'IO'.  It+  provides the following conveniences on top of those libraries:+  .+  - A 'MonadLogger' instance for 'IO'.  Usually this is bad for libraries, but+    can be very convenience for application writers who know they always want+    to log from IO to the console.  If you need to log to other sources, or to+    make logging compile-time optional, use @monad-logger@ directly.+  .+  - A set of shorter functions to type: 'debug', 'log', 'warn'.+  .+  - Logging variants of 'error', 'trace' and 'traceShow', called 'errorL',+    'traceL' and 'traceShowL'.  These use 'unsafePerformIO' in order to act as+    direct replacements, so the usual caveats apply.+  .+  - A global function, 'setDebugLevel', which uses a global 'IORef' to record+    the logging level, saving you from having to carry around the notion of+    "verbosity level" in a Reader environment.+  .+  - A set of "timed" variants, 'timedLog' and 'timedDebug', which report how+    long the specified action took to execute in wall-clock time.++Source-repository head+  type: git+  location: git://github.com/jwiegley/logging.git++Library+    default-language:   Haskell98+    ghc-options: -Wall+    build-depends:+        base                 >= 3 && < 5+      , binary               >= 0.5.1.1+      , bytestring           >= 0.9.2.1+      , fast-logger          >= 2.1.5+      , old-locale           >= 1.0.0.5+      , thyme                >= 0.3.1.0+      , monad-control        >= 0.3.2.3+      , monad-logger         >= 0.3.4.0+      , text                 >= 0.11.3.1+      , transformers         >= 0.3.0.0+      , lifted-base          >= 0.2.2.0+      , vector-space         >= 0.8.6+    exposed-modules:+        Control.Logging+    default-extensions: +        BangPatterns+        FlexibleContexts+        OverloadedStrings++test-suite test+    hs-source-dirs: test+    default-language: Haskell2010+    main-is: main.hs+    type: exitcode-stdio-1.0+    ghc-options: -Wall -threaded+    build-depends:+        base+      , logging+      , unix                 >= 2.5.1.1+      , hspec                >= 1.4+    default-extensions: +        OverloadedStrings
+ test/main.hs view
@@ -0,0 +1,21 @@+module Main where++import Control.Exception+import Control.Concurrent+import Control.Logging+import Prelude hiding (log)+import Test.Hspec++tryAny :: IO a -> IO (Either SomeException a)+tryAny = try++main :: IO ()+main = hspec $ do+    describe "simple logging" $+        it "logs output" $ (withStdoutLogging :: IO () -> IO ())  $ do+            log "Hello, world!"+            timedLog "Did a good thing" $ threadDelay 100000+            _ <- tryAny $ timedLog "Did a bad thing" $+                threadDelay 100000 >> error "foo"+            _ <- tryAny $ errorL "Uh oh"+            return ()