log4hs 0.5.0.0 → 0.6.0.0

raw patch · 14 files changed

+437/−310 lines, 14 filesdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• log4hs.cabal +12/−4
• src/Logging.hs +11/−11
• src/Logging/Global.hs +19/−0
• src/Logging/Global/Internal.hs +45/−0
• src/Logging/Global/TH.hs +47/−0
• src/Logging/Internal.hs +0/−134
• src/Logging/Monad.hs +22/−0
• src/Logging/Monad/Internal.hs +88/−0
• src/Logging/Monad/TH.hs +56/−0
• src/Logging/TH.hs +3/−52
• src/Logging/Types/Manager.hs +22/−2
• test/LoggingTest/GlobalSpec.hs +107/−0
• test/LoggingTest/InternalSpec.hs +0/−107

@@ -17,3 +17,8 @@ - Fix `RotatingFileHandler` bug - Refine tests - Fix `callHandler` redundant check++## V0.6.0+- Add local logging (run in monad)+- Redesign global logging+- Remove `stderrHandler` `stdoutHandler` `defaultRoot`

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 8bbb99f215db2c4adcdb2ab401f23a78b09e5a05c3c874cbb6102403fa6d387d+-- hash: 621a17085d5d95bc8f29ab4cb601c416c58065b9290beebafdcf7544be009732  name:           log4hs-version:        0.5.0.0+version:        0.6.0.0 synopsis:       A python logging style log library description:    Please see the http://hackage.haskell.org/package/log4hs category:       logging@@ -26,12 +26,17 @@       Logging.Config.Json       Logging.Config.Type       Logging.Config.Yaml+      Logging.Global+      Logging.Global.TH+      Logging.Monad+      Logging.Monad.TH       Logging.Prelude       Logging.Types       Logging.TH       Logging.Utils   other-modules:-      Logging.Internal+      Logging.Global.Internal+      Logging.Monad.Internal       Logging.Types.Class       Logging.Types.Class.Filterable       Logging.Types.Class.Handler@@ -58,6 +63,7 @@     , filepath >=1.3 && <1.5     , generic-lens >=0.5 && <2.0     , lens >=4.15 && <5.0+    , mtl >=2.2 && <3.0     , template-haskell >=2.0 && <3.0     , text >=1.2 && <2.0     , time >=1.4 && <2.0@@ -70,7 +76,7 @@   main-is: Main.hs   other-modules:       LoggingTest.ConfigSpec-      LoggingTest.InternalSpec+      LoggingTest.GlobalSpec       LoggingTest.Prelude       LoggingTest.TypesSpec       Paths_log4hs@@ -92,6 +98,7 @@     , hspec-core >=2.1 && <3.0     , lens >=4.15 && <5.0     , log4hs+    , mtl >=2.2 && <3.0     , process >=1.2 && <2.0     , template-haskell >=2.0 && <3.0     , text >=1.2 && <2.0@@ -121,6 +128,7 @@     , generic-lens >=0.5 && <2.0     , lens >=4.15 && <5.0     , log4hs+    , mtl >=2.2 && <3.0     , template-haskell >=2.0 && <3.0     , text >=1.2 && <2.0     , time >=1.4 && <2.0

@@ -16,24 +16,24 @@    module Main ( main ) where -  import           Logging             (run)   import           Logging.Config.Json (getManager)-  import           Logging.TH          (debug, error, fatal, info, logv, warn)+  import           Logging.Global      (run)+  import           Logging.Global.TH   (debug, error, fatal, info, logv, warn)   import           Prelude             hiding (error)    main :: IO ()   main = getManager "{}" >>= flip run app -  myLogger = \"MyLogger.Main\"+  logger = \"Main\"    app :: IO ()   app = do-    $(debug) myLogger \"this is a test message\"-    $(info) myLogger \"this is a test message\"-    $(warn) myLogger \"this is a test message\"-    $(error) myLogger \"this is a test message\"-    $(fatal) myLogger \"this is a test message\"-    $(logv) myLogger \"LEVEL 100\" \"this is a test message\"+    $(debug) logger \"this is a test message\"+    $(info) logger \"this is a test message\"+    $(warn) logger \"this is a test message\"+    $(error) logger \"this is a test message\"+    $(fatal) logger \"this is a test message\"+    $(logv) logger \"LEVEL 100\" \"this is a test message\" @  See "Logging.Config.Json" and "Logging.Config.Yaml" to lean more about@@ -42,9 +42,9 @@ module Logging   ( module Logging.Types   , module Logging.TH-  , module Logging.Internal+  , module Logging.Global   ) where -import           Logging.Internal hiding (log)+import           Logging.Global import           Logging.TH import           Logging.Types

@@ -0,0 +1,19 @@+{-| Run logging globally.++The 'run' function will properly "initialize" and "terminate" the+global "Manager".++If the "Manager"\'s 'catchUncaughtException' is True, the 'run' function will+set an uncaught exception handler that will log all uncaught exceptions,+ and set the handler to the original one before 'run' is complete.+-}++module Logging.Global+  ( run+  , module Logging.Global.TH+  ) where+++import           Logging.Global.Internal+import           Logging.Global.TH+import           Logging.Types

@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Logging.Global.Internal+  ( log+  , run+  ) where+++import           Control.Exception+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.IORef+import           GHC.Conc+import           Prelude                hiding (log)+import           System.IO.Unsafe++import qualified Logging.Monad.Internal as M+import           Logging.Types++{-# NOINLINE ref #-}+ref :: IORef Manager+ref = unsafePerformIO $ newIORef undefined+++log :: MonadIO m+     => Logger -> Level -> String -> (String, String, String, Int)+     -> m ()+log logger level message location = liftIO $ do+  manager <- readIORef ref+  M.runLoggingT (M.log logger level message location) manager+++run :: Manager -> IO a -> IO a+run manager@Manager{..} io = do+    oldHandler <- getUncaughtExceptionHandler+    when catchUncaughtException $ setUncaughtExceptionHandler logException+    bracket_ (initialize manager >> atomicWriteIORef ref manager)+             (terminate manager >> setUncaughtExceptionHandler oldHandler)+             io+  where+    unknownLoc = ("unknown file", "unknown package", "unknown module", 0)++    logException :: SomeException -> IO ()+    logException e = log "" "ERROR" (show e) unknownLoc

@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}++{-| A copy of "Logging.Monad.TH"+-}++module Logging.Global.TH+  ( logv+  , debug+  , info+  , warn+  , error+  , fatal+  ) where++import           Control.Monad.IO.Class  (MonadIO)+import           Language.Haskell.TH++import           Logging.Global.Internal+import           Logging.Types++import           Prelude                 hiding (error, log)++-- | Log "message" with the severity "level".+--+-- The missing type signature:+-- 'MonadIO' m => 'Logger' -> 'Level' -> 'String' -> m ()+logv :: ExpQ+logv = do+  loc <- location+  let filename = loc_filename loc+      packagename = loc_package loc+      modulename = loc_module loc+      lineno = fst $ loc_start loc+      location = (filename, packagename, modulename, lineno)+  [| \logger level msg -> log logger level msg location |]++-- | Log "message" with a specific severity.+--+-- The missing type signature: 'MonadIO' m => 'Logger' -> 'String' -> m ()+debug, info, warn, error, fatal :: ExpQ+debug = [| \logger -> $(logv) logger $ read "DEBUG" |]+info  = [| \logger -> $(logv) logger $ read "INFO" |]+warn  = [| \logger -> $(logv) logger $ read "WARN" |]+error = [| \logger -> $(logv) logger $ read "ERROR" |]+fatal = [| \logger -> $(logv) logger $ read "FATAL" |]

@@ -1,134 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}--module Logging.Internal-  ( run-  , log-  , stderrHandler-  , stdoutHandler-  , defaultRoot-  ) where--import           Control.Exception           (SomeException, bracket_)-import           Control.Lens                (view)-import           Control.Monad               (forM_, void, when)-import           Control.Monad.IO.Class      (MonadIO (..))-import           Data.Default-import           Data.Generics.Product.Typed-import           Data.IORef-import           Data.List                   (dropWhileEnd, group)-import           Data.Map.Lazy               (elems, (!?))-import           Data.Time.Clock-import           Data.Time.Clock.POSIX-import           Data.Time.LocalTime-import           GHC.Conc                    (setUncaughtExceptionHandler)-import           Prelude                     hiding (filter, log)-import           System.FilePath-import           System.IO                   (stderr, stdout)-import           System.IO.Unsafe            (unsafePerformIO)--import           Logging.Prelude-import           Logging.Types--{-# NOINLINE _mgr #-}-_mgr :: IORef Manager-_mgr = unsafePerformIO $ newIORef undefined----- |Run a logging environment.------ You should always write you application inside a logging environment.------ 1. rename "main" function to "originMain" (or whatever you call it)--- 2. write "main" as below------ > main :: IO ()--- > main = run manager originMain--- > ...----run :: Manager -> IO a -> IO a-run mgr@Manager{..} io = do-    when catchUncaughtException $ setUncaughtExceptionHandler uceHandler-    bracket_ (atomicWriteIORef _mgr mgr >> start) shutdown io-  where-    unknownLoc = ("unknown file", "unknown package", "unknown module", 0)--    uceHandler :: SomeException -> IO ()-    uceHandler e = log "" "ERROR" (show e) unknownLoc--    allHandlers = map head $ group $-      concat [ handlers s | s <- (root : (elems sinks)) ]--    start :: IO ()-    start = forM_ allHandlers open--    shutdown :: IO ()-    shutdown = forM_ allHandlers close----- |Low-level logging routine which creates a LogRecord and then calls--- all the handlers of this logger to handle the record.-log :: MonadIO m-     => Logger -> Level -> String -> (String, String, String, Int) -> m ()-log logger level message location = liftIO $ do-    mgr@Manager{..} <- readIORef _mgr-    asctime <- getZonedTime--    let (pathname, pkgname, modulename, lineno) = location-        filename = takeFileName pathname-        utctime = zonedTimeToUTC asctime-        diffTime = utcTimeToPOSIXSeconds utctime-        created = timestamp diffTime-        msecs = microseconds diffTime--    when (not disabled) $ process logger mgr $-      LogRecord logger level message pathname filename pkgname modulename-                lineno asctime utctime created msecs-  where-    process :: Logger -> Manager -> LogRecord -> IO ()-    process logger mgr rcd =-      case lookupSink logger mgr of-        Just sink@Sink{..} -> do-          when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd-          let parentLogger = parent logger-              shouldPropagate = propagate && logger /= parentLogger-          when shouldPropagate $ process parentLogger mgr rcd-        Nothing -> process (parent logger) mgr rcd--    parent :: Logger -> Logger-    parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')--    lookupSink :: Logger -> Manager -> Maybe Sink-    lookupSink logger mgr@Manager{root=root@Sink{logger=rootLogger}, ..}-      | logger `elem` ["", rootLogger] = Just root-      | otherwise = sinks !? logger--    callHandlers :: [SomeHandler] -> LogRecord -> IO ()-    callHandlers handlers rcd = forM_ handlers $ \hdl ->-      Logging.Types.handle hdl rcd--    isSinkEnabledFor :: Sink -> LogRecord -> Bool-    isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}-      | disabled = False-      | level' < level = False-      | otherwise = filter sink rcd---{-# DEPRECATED stderrHandler, stdoutHandler, defaultRoot "Will be removed" #-}---- |A 'StreamHandler' bound to 'stderr'-stderrHandler :: StreamHandler-stderrHandler = StreamHandler def [] "{message}" stderr---- |A 'StreamHandler' bound to 'stdout'-stdoutHandler :: StreamHandler-stdoutHandler = StreamHandler def [] "{message}" stdout---- |Default root sink which is used by "Logging.Config.Json" and--- "Logging.Config.Yaml" when __root__ sink is omitted.----defaultRoot :: Sink-defaultRoot = Sink "" "DEBUG" [] [toHandler stderrHandler] False False

@@ -0,0 +1,22 @@+{-| Run logging in a 'Reader' monad.++You should 'initialize' the 'Manager' before using it in the 'Reader'+monad, and 'terminate' it when it is no longer needed.++If you want to log uncaught exceptions,+see "GHC.Conc.setUncaughtExceptionHandler".+-}++++module Logging.Monad+  ( LoggingT+  , runLoggingT+  -- ** Log routines+  , module Logging.Monad.TH+  ) where+++import           Logging.Monad.Internal+import           Logging.Monad.TH+import           Logging.Types

@@ -0,0 +1,88 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}++module Logging.Monad.Internal+  ( LoggingT+  , runLoggingT+  , log+  ) where+++import           Control.Exception           (SomeException, bracket_)+import           Control.Lens                (view)+import           Control.Monad+import           Control.Monad.IO.Class      (MonadIO (..))+import           Control.Monad.Reader+import           Data.Default+import           Data.Generics.Product.Typed+import           Data.IORef+import           Data.List                   (dropWhileEnd, group)+import           Data.Map.Lazy               (elems, (!?))+import           Data.Time.Clock+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import           GHC.Conc                    (setUncaughtExceptionHandler)+import           Prelude                     hiding (filter, log)+import           System.FilePath+import           System.IO                   (stderr, stdout)+import           System.IO.Unsafe            (unsafePerformIO)++import           Logging.Prelude+import           Logging.Types+++type LoggingT m a = ReaderT Manager m a+++runLoggingT :: MonadIO m => LoggingT m a -> Manager -> m a+runLoggingT = runReaderT+++log :: MonadIO m+    => Logger -> Level -> String -> (String, String, String, Int)+    -> LoggingT m ()+log logger level message location = do+    manager@Manager{..} <- ask+    asctime <- lift $ liftIO $ getZonedTime++    let (pathname, pkgname, modulename, lineno) = location+        filename = takeFileName pathname+        utctime = zonedTimeToUTC asctime+        diffTime = utcTimeToPOSIXSeconds utctime+        created = timestamp diffTime+        msecs = microseconds diffTime++    when (not disabled) $ lift $ liftIO $ process logger manager $+      LogRecord logger level message pathname filename pkgname modulename+                lineno asctime utctime created msecs+  where+    process :: Logger -> Manager -> LogRecord -> IO ()+    process logger manager rcd =+      case lookupSink logger manager of+        Just sink@Sink{..} -> do+          when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd+          let parentLogger = parent logger+              shouldPropagate = propagate && logger /= parentLogger+          when shouldPropagate $ process parentLogger manager rcd+        Nothing -> process (parent logger) manager rcd++    parent :: Logger -> Logger+    parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')++    lookupSink :: Logger -> Manager -> Maybe Sink+    lookupSink logger manager@Manager{root=root@Sink{logger=rootLogger}, ..}+      | logger `elem` ["", rootLogger] = Just root+      | otherwise = sinks !? logger++    callHandlers :: [SomeHandler] -> LogRecord -> IO ()+    callHandlers handlers rcd = forM_ handlers $ \hdl ->+      Logging.Types.handle hdl rcd++    isSinkEnabledFor :: Sink -> LogRecord -> Bool+    isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}+      | disabled = False+      | level' < level = False+      | otherwise = filter sink rcd

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}++{-| This module provides a series of log routines that create a 'LogRecord'+ and then emit a log event.++The log routines use "Language.Haskell.TH" to obtain some fields related to+where they are called,+e.g. __filename__, __pkgname__, __modulename__, __lineno__++When use these log routines, you should enable __TemplateHaskell__+language extension.+-}++module Logging.Monad.TH+  ( logv+  , debug+  , info+  , warn+  , error+  , fatal+  ) where++import           Control.Monad.IO.Class (MonadIO)+import           Language.Haskell.TH++import           Logging.Monad.Internal+import           Logging.Types++import           Prelude                hiding (error, log)++-- | Log "message" with the severity "level".+--+-- The missing type signature:+-- 'MonadIO' m => 'Logger' -> 'Level' -> 'String' -> 'LoggingT' m ()+logv :: ExpQ+logv = do+  loc <- location+  let filename = loc_filename loc+      packagename = loc_package loc+      modulename = loc_module loc+      lineno = fst $ loc_start loc+      location = (filename, packagename, modulename, lineno)+  [| \logger level msg -> log logger level msg location |]++-- | Log "message" with a specific severity.+--+-- The missing type signature:+-- 'MonadIO' m => 'Logger' -> 'String' -> 'LoggingT' m ()+debug, info, warn, error, fatal :: ExpQ+debug = [| \logger -> $(logv) logger $ read "DEBUG" |]+info  = [| \logger -> $(logv) logger $ read "INFO" |]+warn  = [| \logger -> $(logv) logger $ read "WARN" |]+error = [| \logger -> $(logv) logger $ read "ERROR" |]+fatal = [| \logger -> $(logv) logger $ read "FATAL" |]

@@ -1,54 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE TemplateHaskell   #-}--{-| This module provides a series of log routines that create a 'LogRecord'- and then emit a log event.--The log routines use "Language.Haskell.TH" to obtain some fields related to-where they are called,-e.g. __filename__, __pkgname__, __modulename__, __lineno__--When use these log routines, you should enable __TemplateHaskell__-language extension.--}--module Logging.TH-  ( logv-  , debug-  , info-  , warn-  , error-  , fatal+module Logging.TH {-# DEPRECATED "Renamed as Logging.TH.Global.TH" #-}+  ( module Logging.Global.TH   ) where -import           Control.Monad.IO.Class (MonadIO)-import           Language.Haskell.TH--import           Logging.Internal-import           Logging.Types--import           Prelude                hiding (error, log)---- | Log "message" with the severity "level".------ The missing type signature: 'MonadIO' m => 'Logger' -> 'Level' -> 'String' -> m ()-logv :: ExpQ-logv = do-  loc <- location-  let filename = loc_filename loc-      packagename = loc_package loc-      modulename = loc_module loc-      lineno = fst $ loc_start loc-      location = (filename, packagename, modulename, lineno)-  [| \logger level msg -> log logger level msg location |]---- | Log "message" with a specific severity.------ The missing type signature: 'MonadIO' m => 'Logger' -> 'String' -> m ()-debug, info, warn, error, fatal :: ExpQ-debug = [| \logger -> $(logv) logger $ read "DEBUG" |]-info = [| \logger -> $(logv) logger $ read "INFO" |]-warn = [| \logger -> $(logv) logger $ read "WARN" |]-error = [| \logger -> $(logv) logger $ read "ERROR" |]-fatal = [| \logger -> $(logv) logger $ read "FATAL" |]+import           Logging.Global.TH

@@ -1,7 +1,15 @@-module Logging.Types.Manager ( Manager(..) ) where+{-# LANGUAGE RecordWildCards #-} -import           Data.Map.Lazy      (Map)+module Logging.Types.Manager+  ( Manager(..)+  , initialize+  , terminate+  ) where +import           Data.List                   (nub)+import           Data.Map.Lazy               (Map, elems)++import           Logging.Types.Class.Handler import           Logging.Types.Sink  @@ -12,3 +20,15 @@                        , disabled               :: Bool                        , catchUncaughtException :: Bool                        }+++-- | Initialize a 'Manager', open all its handlers.+initialize :: Manager -> IO ()+initialize Manager{..} = mapM_ open $+  nub $ concat [ handlers | Sink{..} <- (root : (elems sinks)) ]+++-- | Terminate a 'Manager', close all its handlers.+terminate :: Manager -> IO ()+terminate Manager{..} = mapM_ close $+  nub $ concat [ handlers | Sink{..} <- (root : (elems sinks)) ]

@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module LoggingTest.GlobalSpec ( spec ) where++import           Control.Monad+import           Data.Default            (def)+import           Data.List               (intercalate)+import qualified Data.Map                as M+import           Data.Word+import           Prelude                 hiding (error)+import           System.IO+import           System.IO.Unsafe        (unsafePerformIO)+import           System.Process          (createPipe)+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Test.QuickCheck.Monadic+import           Text.Format++import           Logging                 hiding (run)+import           Logging.TH+import           LoggingTest.Prelude++spec :: Spec+spec = describe "run & log" $ do+  let levels = ["DEBUG", "INFO", "WARN", "ERROR", "FATAL"]+      loggers = [ ("root", "DEBUG", [], ["DEBUG"], False, False)+                , ("Disabled", "DEBUG", [], ["DEBUG"], True, False)+                , ("Debug", "DEBUG", [], ["DEBUG", "INFO"], False, False)+                , ("Info", "INFO", ["Info.A"], ["DEBUG", "INFO"], False, False)+                , ("Warn", "WARN", [], ["WARN"], False, False)+                , ("Warn.Error", "ERROR", [], ["ERROR"], False, False)+                , ("Error", "ERROR", [], ["ERROR"], False, True)+                , ("Error.Fatal", "FATAL", [], ["FATAL"], False, True)+                ]+  handlers <- fmap M.fromList $ runIO $ forM levels $ \level -> do+    (read, write) <- createPipe+    hSetEncoding read utf8 >> hSetEncoding write utf8+    let handler = toHandler $ StreamHandler level [] "{message}" write+    return $ (level, (handler, read))+  sinks <- fmap M.fromList $ runIO $ forM loggers $ \item -> do+    let (logger, level, fs, hs, disabled, propagate) = item+        logger' = if logger == "root" then "" else logger+        hs' = [fst (handlers M.! h) | h <- hs]+        sink = Sink logger' level fs hs' disabled propagate+    return (logger, sink)++  let root = sinks M.! "root"+      sinks' = M.delete "root" sinks+      disabledManager = Manager root sinks' True False+      manager = Manager root sinks' False False++  prop "filter" $ \(MessageString message) -> monadicIO $ do+    -- manager disabled+    run $ runLog disabledManager $ $(info) "Debug" message+    msgs <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", ""] ==  msgs+    -- sink disabled+    run $ runLog manager $ $(debug) "Disabled" message+    msg1 <- run $ hTryGetLine $ snd $ handlers M.! "DEBUG"+    assert $ msg1 == ""+    -- sink level reject+    run $ runLog manager $ $(debug) "Info.A" message+    msgs1 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", ""] == msgs1+    -- sink filterer reject+    run $ runLog manager $ $(info) "Info.B" message+    msgs2 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", ""] ==  msgs2+    -- pass 1+    run $ runLog manager $ $(info) "Debug" message+    msgs3 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message] == msgs3+    -- pass 2+    run $ runLog manager $ $(info) "Info.A" message+    msgs4 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message] == msgs4++  prop "propagate" $ \(MessageString message) -> monadicIO $ do+    -- propagation disabled 1+    run $ runLog manager $ $(warn) "Warn" message+    msgs <- run $ forM ["DEBUG", "WARN"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", message] == msgs+    -- propagation disabled 2+    run $ runLog manager $ $(error) "Warn.Error" message+    msgs1 <- run $ forM ["DEBUG", "WARN", "ERROR"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", "", message] == msgs1+    -- propagation enabled 1+    run $ runLog manager $ $(error) "Error" message+    msgs2 <- run $ forM ["DEBUG", "ERROR"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message] == msgs2+    -- propagation enabled 2+    run $ runLog manager $ $(fatal) "Error.Fatal" message+    msgs3 <- run $ forM ["DEBUG", "ERROR", "FATAL"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message, message] == msgs3

@@ -1,107 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}--module LoggingTest.InternalSpec ( spec ) where--import           Control.Monad-import           Data.Default            (def)-import           Data.List               (intercalate)-import qualified Data.Map                as M-import           Data.Word-import           Prelude                 hiding (error)-import           System.IO-import           System.IO.Unsafe        (unsafePerformIO)-import           System.Process          (createPipe)-import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck-import           Test.QuickCheck.Monadic-import           Text.Format--import           Logging                 hiding (run)-import           Logging.TH-import           LoggingTest.Prelude--spec :: Spec-spec = describe "run & log" $ do-  let levels = ["DEBUG", "INFO", "WARN", "ERROR", "FATAL"]-      loggers = [ ("root", "DEBUG", [], ["DEBUG"], False, False)-                , ("Disabled", "DEBUG", [], ["DEBUG"], True, False)-                , ("Debug", "DEBUG", [], ["DEBUG", "INFO"], False, False)-                , ("Info", "INFO", ["Info.A"], ["DEBUG", "INFO"], False, False)-                , ("Warn", "WARN", [], ["WARN"], False, False)-                , ("Warn.Error", "ERROR", [], ["ERROR"], False, False)-                , ("Error", "ERROR", [], ["ERROR"], False, True)-                , ("Error.Fatal", "FATAL", [], ["FATAL"], False, True)-                ]-  handlers <- fmap M.fromList $ runIO $ forM levels $ \level -> do-    (read, write) <- createPipe-    hSetEncoding read utf8 >> hSetEncoding write utf8-    let handler = toHandler $ StreamHandler level [] "{message}" write-    return $ (level, (handler, read))-  sinks <- fmap M.fromList $ runIO $ forM loggers $ \item -> do-    let (logger, level, fs, hs, disabled, propagate) = item-        logger' = if logger == "root" then "" else logger-        hs' = [fst (handlers M.! h) | h <- hs]-        sink = Sink logger' level fs hs' disabled propagate-    return (logger, sink)--  let root = sinks M.! "root"-      sinks' = M.delete "root" sinks-      disabledManager = Manager root sinks' True False-      manager = Manager root sinks' False False--  prop "filter" $ \(MessageString message) -> monadicIO $ do-    -- manager disabled-    run $ runLog disabledManager $ $(info) "Debug" message-    msgs <- run $ forM ["DEBUG", "INFO"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ ["", ""] ==  msgs-    -- sink disabled-    run $ runLog manager $ $(debug) "Disabled" message-    msg1 <- run $ hTryGetLine $ snd $ handlers M.! "DEBUG"-    assert $ msg1 == ""-    -- sink level reject-    run $ runLog manager $ $(debug) "Info.A" message-    msgs1 <- run $ forM ["DEBUG", "INFO"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ ["", ""] == msgs1-    -- sink filterer reject-    run $ runLog manager $ $(info) "Info.B" message-    msgs2 <- run $ forM ["DEBUG", "INFO"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ ["", ""] ==  msgs2-    -- pass 1-    run $ runLog manager $ $(info) "Debug" message-    msgs3 <- run $ forM ["DEBUG", "INFO"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ [message, message] == msgs3-    -- pass 2-    run $ runLog manager $ $(info) "Info.A" message-    msgs4 <- run $ forM ["DEBUG", "INFO"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ [message, message] == msgs4--  prop "propagate" $ \(MessageString message) -> monadicIO $ do-    -- propagation disabled 1-    run $ runLog manager $ $(warn) "Warn" message-    msgs <- run $ forM ["DEBUG", "WARN"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ ["", message] == msgs-    -- propagation disabled 2-    run $ runLog manager $ $(error) "Warn.Error" message-    msgs1 <- run $ forM ["DEBUG", "WARN", "ERROR"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ ["", "", message] == msgs1-    -- propagation enabled 1-    run $ runLog manager $ $(error) "Error" message-    msgs2 <- run $ forM ["DEBUG", "ERROR"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ [message, message] == msgs2-    -- propagation enabled 2-    run $ runLog manager $ $(fatal) "Error.Fatal" message-    msgs3 <- run $ forM ["DEBUG", "ERROR", "FATAL"] $ \level ->-      hTryGetLine $ snd $ handlers M.! level-    assert $ [message, message, message] == msgs3