diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +import Criterion.Main +import Data.Aeson +import Data.Aeson.QQ.Simple +import Data.Maybe +import Logging +import System.IO.Unsafe + + +main :: IO () +main = run manager $ defaultMain $ + [ bgroup "stderr" [ bench "simple" $ nfIO $ $(debug) "Stderr.Simple" msg100 + , bench "normal" $ nfIO $ $(info) "Stderr.Normal" msg100 + , bench "full" $ nfIO $ $(fatal) "Stderr.Full" msg100 + ] + , bgroup "file" [ bench "simple" $ nfIO $ $(debug) "File.Simple" msg100 + , bench "normal" $ nfIO $ $(info) "File.Normal" msg100 + , bench "full" $ nfIO $ $(fatal) "File.Full" msg100 + ] + ] + + +msg100 :: String +msg100 = replicate 100 'W' + + +manager :: Manager +{-# NOINLINE manager #-} +manager = unsafePerformIO $ fromJust $ decode $ encode $ + [aesonQQ|{ + "disabled": false, + "catchUncaughtException": true, + "loggers": { + "Stderr.Simple": { + "handlers": ["stderr.simple"], + "propagate": false + }, + "Stderr.Normal": { + "handlers": ["stderr.normal"], + "propagate": false + }, + "Stderr.Full": { + "handlers": ["stderr.full"], + "propagate": false + }, + "File.Simple": { + "handlers": ["file.simple"], + "propagate": false + }, + "File.Normal": { + "handlers": ["file.normal"], + "propagate": false + }, + "File.Full": { + "handlers": ["file.full"], + "propagate": false + } + }, + "handlers": { + "stderr.simple": { + "type": "StreamHandler", + "stream": "stderr", + "level": "DEBUG", + "formatter": "simple" + }, + "stderr.normal": { + "type": "StreamHandler", + "stream": "stderr", + "level": "INFO", + "formatter": "normal" + }, + "stderr.full": { + "type": "StreamHandler", + "stream": "stderr", + "level": "ERROR", + "formatter": "full" + }, + "file.simple": { + "type": "FileHandler", + "level": "DEBUG", + "formatter": "simple", + "file": "/tmp/log4hs/benchmark.simple.log" + }, + "file.normal": { + "type": "FileHandler", + "level": "INFO", + "formatter": "normal", + "file": "/tmp/log4hs/benchmark.normal.log" + }, + "file.full": { + "type": "FileHandler", + "level": "ERROR", + "formatter": "full", + "file": "/tmp/log4hs/benchmark.full.log" + } + }, + "formatters": { + "simple": "%(message)s", + "normal": "%(asctime)s - %(level)s - %(logger)s] %(message)s", + "full": "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s" + } + }|] + diff --git a/log4hs.cabal b/log4hs.cabal --- a/log4hs.cabal +++ b/log4hs.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 6da912ef94ad42318d7758fcdd3d5893c0f3d6c4863cc543e25dd6f91ba71bb2 +-- hash: f2370e21e4ee599e5f39cb01456bcda6598b0a4ed115c1b69a0f94049635a3d5 name: log4hs -version: 0.0.5.0 +version: 0.0.6.0 synopsis: A python logging style log library description: Please see the http://hackage.haskell.org/package/log4hs category: logging @@ -33,12 +33,14 @@ hs-source-dirs: src build-depends: - aeson >=0.8 && <1.5 + aeson >=1.2 && <1.5 , base >=4.7 && <5 - , containers >=0.6 && <0.7 + , containers >=0.5 && <0.7 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5 + , generic-lens >=0.5 && <2.0 + , lens >=4.15 && <5.0 , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 @@ -57,16 +59,42 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck >=2.0 && <3.0 - , aeson >=0.8 && <1.5 + , aeson >=1.2 && <1.5 , base >=4.7 && <5 - , containers >=0.6 && <0.7 + , containers >=0.5 && <0.7 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5 + , generic-lens >=0.5 && <2.0 , hspec >=2.1 && <3.0 , hspec-core >=2.1 && <3.0 + , lens >=4.15 && <5.0 , log4hs , process >=1.2 && <2.0 + , template-haskell >=2.0 && <3.0 + , text >=1.2 && <2.0 + , time >=1.4 && <2.0 + default-language: Haskell2010 + +benchmark log4hs-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_log4hs + hs-source-dirs: + bench + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.2 && <1.5 + , base >=4.7 && <5 + , containers >=0.5 && <0.7 + , criterion >=1.0 && <2.0 + , data-default >=0.5 && <1.0 + , directory >=1.2 && <1.4 + , filepath >=1.3 && <1.5 + , generic-lens >=0.5 && <2.0 + , lens >=4.15 && <5.0 + , log4hs , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 diff --git a/src/Logging/Aeson.hs b/src/Logging/Aeson.hs --- a/src/Logging/Aeson.hs +++ b/src/Logging/Aeson.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Logging.Aeson ( @@ -10,14 +11,14 @@ -- $aesondoc ) where -import Control.Applicative (pure) +import Control.Applicative (pure) import Control.Concurrent.MVar +import Control.Lens (set) import Data.Aeson -import Data.Aeson.Types (Parser, typeMismatch) +import Data.Aeson.Types (Parser, typeMismatch) import Data.Default -import Data.Map.Lazy (Map, (!)) -import qualified Data.Map.Lazy as M -import qualified Data.Text as T +import Data.Generics.Product.Typed +import qualified Data.Map.Lazy as M import System.Directory import System.FilePath import System.IO @@ -45,7 +46,7 @@ \"handlers\": {\"console\": {}, \"file\": {}}, \"formatters\": {\"default\": {}, \"simple\": {}}, \"disabled\": false, - \"catchUncaughtException\": true, + \"catchUncaughtException\": true } @ @@ -132,7 +133,7 @@ instance FromJSON Filter where - parseJSON v = (\s -> Filter s $ length s) <$> parseJSON v + parseJSON v = Filter <$> parseJSON v instance FromJSON Formatter where @@ -155,7 +156,7 @@ parseStream _ = error "Logging.Aeson: no parse (stream)" -instance FromJSON (IO HandlerT) where +instance FromJSON (IO SomeHandler) where parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v) where openLogFile :: FilePath -> IO Handle @@ -166,24 +167,24 @@ hSetEncoding stream utf8 return stream - parseHandler :: String -> Object -> Parser (IO HandlerT) + parseHandler :: String -> Object -> Parser (IO SomeHandler) parseHandler "StreamHandler" v = do hdl <- parseJSON (Object v) - return $ HandlerT <$> (hdl :: IO StreamHandler) + return $ toHandler <$> (hdl :: IO StreamHandler) parseHandler "FileHandler" v = do hdl :: (IO StreamHandler) <- parseJSON (Object v) stream <- openLogFile <$> (v .: "file" .!= "default.log") hdl' <- mapAp2 (pure $ \h s -> h {stream = s}) hdl stream - return $ HandlerT <$> hdl' + return $ toHandler <$> hdl' parseHandler t _ = error $ "Logging.Aeson: no parse (Handler" ++ t ++")" -instance FromJSON (Map String Formatter -> IO HandlerT) where +instance FromJSON (M.Map String Formatter -> IO SomeHandler) where parseJSON = withObject "Handler" $ \v -> do hdlio <- parseJSON (Object v) key <- v .:? "formatter" .!= "" - return $ \fs -> hdlio >>= \(HandlerT hdl) -> do - return $ HandlerT $ setFormatter hdl (M.findWithDefault def key fs) + return $ \fs -> hdlio >>= \hdl -> return $ + set (typed @Formatter) (M.findWithDefault def key fs) hdl instance FromJSON (Sink) where @@ -196,23 +197,23 @@ <*> v .:? "propagate" .!= False -instance FromJSON (String -> Map String HandlerT -> Sink) where +instance FromJSON (String -> M.Map String SomeHandler -> Sink) where parseJSON = withObject "Sink" $ \v -> do sink <- parseJSON (Object v) keys <- v .:? "handlers" .!= [] return $ \lgr hs -> sink { logger = if lgr == "root" then "" else lgr - , handlers = [hs ! k | k <- keys] + , handlers = [hs M.! k | k <- keys] } -type Formatters = Map String Formatter -type HandlerTsMakerIO = Map String (Formatters -> IO HandlerT) -type SinksMaker = Map String (String -> Map String HandlerT -> Sink) +type Formatters = M.Map String Formatter +type HandlersMakerIO = M.Map String (Formatters -> IO SomeHandler) +type SinksMaker = M.Map String (String -> M.Map String SomeHandler -> Sink) instance FromJSON (IO Manager) where parseJSON = withObject "Manager" $ \v -> do fmts :: Formatters <- v .:? "formatters" .!= (object []) >>= parseJSON - hdls :: HandlerTsMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON + hdls :: HandlersMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON sinks :: SinksMaker <- v .:? "loggers" .!= (object []) >>= parseJSON disabled <- v .:? "disabled" .!= False diff --git a/src/Logging/Internal.hs b/src/Logging/Internal.hs --- a/src/Logging/Internal.hs +++ b/src/Logging/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Logging.Internal ( run @@ -12,19 +13,21 @@ ) where import Control.Concurrent.MVar -import Control.Exception (SomeException, bracket_) -import Control.Monad (forM_, void, when) -import Control.Monad.IO.Class (MonadIO (..)) +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) -import Data.Map.Lazy ((!?)) +import Data.List (dropWhileEnd) +import Data.Map.Lazy ((!?)) import Data.Time.Clock import Data.Time.LocalTime -import GHC.Conc (setUncaughtExceptionHandler) -import Prelude hiding (filter, log) -import System.IO (Handle, stderr, stdout) -import System.IO.Unsafe (unsafePerformIO) +import GHC.Conc (setUncaughtExceptionHandler) +import Prelude hiding (filter, log) +import System.IO (Handle, stderr, stdout) +import System.IO.Unsafe (unsafePerformIO) import Logging.Types @@ -58,7 +61,7 @@ shutdown = closeHandlers root >> forM_ sinks closeHandlers closeHandlers :: Sink -> IO () - closeHandlers Sink{..} = forM_ handlers $ \(HandlerT hdl) -> close hdl + closeHandlers Sink{..} = forM_ handlers close -- |Low-level logging routine which creates a LogRecord and then calls @@ -92,9 +95,9 @@ | logger `elem` ["", rootLogger] = Just root | otherwise = sinks !? logger - callHandlers :: [HandlerT] -> LogRecord -> IO () - callHandlers handlers rcd = forM_ handlers $ \hdlt@(HandlerT hdl) -> - when (isHandlerEnableFor hdlt rcd) $ void $ Logging.Types.handle hdl rcd + callHandlers :: [SomeHandler] -> LogRecord -> IO () + callHandlers handlers rcd = forM_ handlers $ \hdl -> + when (isHandlerEnableFor hdl rcd) $ void $ Logging.Types.handle hdl rcd isSinkEnabledFor :: Sink -> LogRecord -> Bool isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'} @@ -102,10 +105,10 @@ | level' < level = False | otherwise = filter sink rcd - isHandlerEnableFor :: HandlerT -> LogRecord -> Bool - isHandlerEnableFor (HandlerT hdl) rcd@LogRecord{level=level'} - | level' < getLevel hdl = False - | otherwise = filter (getFilterer hdl) rcd + isHandlerEnableFor :: SomeHandler -> LogRecord -> Bool + isHandlerEnableFor hdl rcd@LogRecord{level=level'} + | level' < (view (typed @Level) hdl) = False + | otherwise = filter (view (typed @Filterer) hdl) rcd -- |A ultility function for creating 'StreamHandler' @@ -128,4 +131,4 @@ -- -- You can use it when you make 'Manager' manually. defaultRoot :: Sink -defaultRoot = Sink "" "DEBUG" [] [HandlerT stderrHandler] False False +defaultRoot = Sink "" "DEBUG" [] [toHandler stderrHandler] False False diff --git a/src/Logging/Types.hs b/src/Logging/Types.hs --- a/src/Logging/Types.hs +++ b/src/Logging/Types.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} module Logging.Types ( Logger(..) @@ -13,8 +16,8 @@ , Filter(..) , Filterer , Formatter(..) + , SomeHandler(..) , StreamHandler(..) - , HandlerT(..) , Sink(..) , Manager(..) , Filterable(..) @@ -22,21 +25,24 @@ , Handler(..) ) where -import Control.Concurrent.MVar (MVar, putMVar, takeMVar) -import Control.Exception (bracket) -import Control.Monad (unless, when) +import Control.Concurrent.MVar (MVar, putMVar, takeMVar) +import Control.Exception (bracket) +import Control.Lens (set, view) +import Control.Monad (unless, when) import Data.Default -import Data.List (stripPrefix) -import Data.Map.Lazy (Map) +import Data.Generics.Product.Typed +import Data.List (stripPrefix) +import Data.Map.Lazy (Map) import Data.String import Data.Time.Clock -import qualified Data.Time.Format as TF +import qualified Data.Time.Format as TF import Data.Time.LocalTime -import Language.Haskell.TH.Syntax (Lift) -import Prelude hiding (filter) +import Data.Typeable +import GHC.Generics +import Prelude hiding (filter) import System.FilePath import System.IO -import Text.Printf (printf) +import Text.Printf (printf) -- |'Logger' is just a name. type Logger = String @@ -58,7 +64,7 @@ -- >>> "DEBUG" == (Level 10) -- True -- -newtype Level = Level Int deriving (Lift, Eq, Ord) +newtype Level = Level Int deriving (Eq, Ord) instance Show Level where show (Level 0) = "NOTSET" @@ -118,15 +124,10 @@ -- events logged by loggers "A.B", "A.B.C", "A.B.C.D", "A.B.D" etc. -- but not "A.BB", "B.A.B" etc. -- If initialized name with the empty string, all events are passed. -data Filter = Filter { name :: String - , nlen :: Int - } +newtype Filter = Filter Logger deriving (Read, Show, Eq) instance IsString Filter where - fromString s = Filter s $ length s - -instance Eq Filter where - (==) f s = (==) (name f) (name s) + fromString = Filter -- |List of Filter @@ -170,6 +171,31 @@ def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z" +type Lock = MVar () + + +-- |The 'SomeHandler' type is the root of the handler type hierarchy. +-- It hold the real 'Handler' instance +data SomeHandler where + SomeHandler :: Handler h => h -> SomeHandler + +instance {-# OVERLAPPING #-} HasType Level SomeHandler where + getTyped (SomeHandler h) = view (typed @Level) h + setTyped v (SomeHandler h) = SomeHandler $ set (typed @Level) v h + +instance {-# OVERLAPPING #-} HasType Filterer SomeHandler where + getTyped (SomeHandler h) = view (typed @Filterer) h + setTyped v (SomeHandler h) = SomeHandler $ set (typed @Filterer) v h + +instance {-# OVERLAPPING #-} HasType Formatter SomeHandler where + getTyped (SomeHandler h) = view (typed @Formatter) h + setTyped v (SomeHandler h) = SomeHandler $ set (typed @Formatter) v h + +instance {-# OVERLAPPING #-} HasType Lock SomeHandler where + getTyped (SomeHandler h) = view (typed @Lock) h + setTyped v (SomeHandler h) = SomeHandler $ set (typed @Lock) v h + + -- | A handler type which writes logging records, appropriately formatted, -- to a stream. -- @@ -181,13 +207,8 @@ , level :: Level , filterer :: Filterer , formatter :: Formatter - , lock :: MVar () - } - - --- |A GADT represents any 'Handler' instance -data HandlerT where - HandlerT :: Handler a => a -> HandlerT + , lock :: Lock + } deriving (Generic) -- |'Sink' represents a single logging channel. @@ -209,7 +230,7 @@ data Sink = Sink { logger :: Logger , level :: Level , filterer :: Filterer - , handlers :: [HandlerT] + , handlers :: [SomeHandler] , disabled :: Bool , propagate :: Bool -- ^ It will pop up until root or the -- ancestor's propagation is disabled @@ -234,11 +255,11 @@ filter (f:fs) rcd = (filter f) rcd && (filter fs rcd) instance Filterable Filter where - filter f rcd@LogRecord{..} - | (nlen f) == 0 = True - | otherwise = case stripPrefix (name f) logger of - Just "" -> True -- filter name == record logger - Just ('.':_) -> True -- filter name is record logger's child + filter (Filter self) rcd@LogRecord{..} + | self == "" = True + | otherwise = case stripPrefix self logger of + Just "" -> True -- self == logger + Just ('.':_) -> True -- self == parent logger _ -> False instance Filterable Sink where @@ -289,50 +310,55 @@ -- |A type class that abstracts the characteristics of a 'Handler' -class Handler a where - getLevel :: a -> Level - setLevel :: a -> Level -> a - - getFilterer :: a -> Filterer - setFilterer :: a -> Filterer -> a - - getFormatter :: a -> Formatter - setFormatter :: a -> Formatter -> a - - acquire :: a -> IO () - release :: a -> IO () - - with :: a -> (a -> IO b) -> IO b - with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l) - +class ( HasType Level a + , HasType Filterer a + , HasType Formatter a + , HasType Lock a + , Typeable a + ) => Handler a where emit :: a -> LogRecord -> IO () + flush :: a -> IO () + flush _ = return () + close :: a -> IO () + close _ = return () handle :: a -> LogRecord -> IO Bool handle hdl rcd = do - let rv = filter (getFilterer hdl) rcd - when rv $ with hdl (`emit` rcd) - return rv + let rv = filter (view (typed @Filterer) hdl) rcd + when rv $ with hdl (`emit` rcd) + return rv + where + acquire :: a -> IO () + acquire = takeMVar . (view $ typed @Lock) -instance Handler StreamHandler where - getLevel = level - setLevel h v = h { level = v } + release :: a -> IO () + release = (`putMVar` ()) . (view $ typed @Lock) - getFilterer = filterer - setFilterer h f = h { filterer = f } + with :: a -> (a -> IO b) -> IO b + with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l) - getFormatter = formatter - setFormatter h f = h { formatter = f } + fromHandler :: SomeHandler -> Maybe a + fromHandler (SomeHandler h) = cast h - acquire = takeMVar . lock - release = (`putMVar` ()) . lock + toHandler :: a -> SomeHandler + toHandler = SomeHandler +instance Handler SomeHandler where + emit (SomeHandler h) = emit h + flush (SomeHandler h) = flush h + close (SomeHandler h) = close h + fromHandler = Just . id + toHandler = id + +instance Handler StreamHandler where emit hdl rcd = do - hPutStrLn (stream hdl) $ format (getFormatter hdl) rcd + hPutStrLn (stream hdl) $ format (view (typed @Formatter) hdl) rcd flush hdl flush = hFlush . stream + close StreamHandler{..} = do isClosed <- hIsClosed stream unless isClosed $ hIsTerminalDevice stream >>= (`unless` (hClose stream)) diff --git a/test/Logging/AesonSpec.hs b/test/Logging/AesonSpec.hs --- a/test/Logging/AesonSpec.hs +++ b/test/Logging/AesonSpec.hs @@ -2,16 +2,19 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Logging.AesonSpec ( spec ) where +import Control.Lens (view) import Control.Monad import Data.Aeson -import Data.Aeson.QQ.Simple (aesonQQ) -import Data.Default (def) -import Data.List (intercalate) -import qualified Data.Map as M -import Data.Maybe (fromJust) +import Data.Aeson.QQ.Simple (aesonQQ) +import Data.Default (def) +import Data.Generics.Product.Typed +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Maybe (fromJust) import System.IO import System.IO.Unsafe import Test.Hspec @@ -33,8 +36,8 @@ filterSpec :: Spec filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do prop "decode" $ \fs -> - let name = intercalate "." fs - in (decode $ encode name) == Just (Filter name $ length name) + let logger = intercalate "." fs + in (decode $ encode logger) == Just (Filter logger) formatterSpec :: Spec @@ -74,10 +77,10 @@ stream == stdout `shouldBe` True level == "DEBUG" `shouldBe` True - filterer == [Filter "Module.Submodule" 16] `shouldBe` True + filterer == [Filter "Module.Submodule"] `shouldBe` True formatter == def {fmt = "default"} `shouldBe` True - it "decode (formatters -> HandlerT)" $ do + it "decode (formatters -> SomeHandler)" $ do let simple = def {fmt = "%(logger)s: %(message)s"} func = fromJust $ decode $ encode [aesonQQ| @@ -89,10 +92,10 @@ } |] - (HandlerT handler) <- func $ M.singleton ("simple" :: String) simple - getLevel handler == "DEBUG" `shouldBe` True - getFilterer handler == [Filter "Module.Submodule" 16] `shouldBe` True - getFormatter handler == simple `shouldBe` True + handler@(SomeHandler _) <- func $ M.singleton ("simple" :: String) simple + view (typed @Level) handler == "DEBUG" `shouldBe` True + view (typed @Filterer) handler == ["Module.Submodule"] `shouldBe` True + view (typed @Formatter) handler == simple `shouldBe` True sinkSpec :: Spec @@ -111,14 +114,14 @@ logger `shouldBe` "placeholder" level `shouldBe` "DEBUG" - filterer == [Filter "Module.Submodule" 16] `shouldBe` True + filterer == ["Module.Submodule"] `shouldBe` True length handlers `shouldBe` 0 disabled `shouldBe` False propagate `shouldBe` True it "decode (logger -> handlers -> sink)" $ do - let handlerMap = M.fromList [ ("console", HandlerT stderrHandler) - , ("file" :: String, HandlerT stderrHandler) + let handlerMap = M.fromList [ ("console", toHandler stderrHandler) + , ("file" :: String, toHandler stderrHandler) ] func = fromJust $ decode $ encode $ [aesonQQ| @@ -132,7 +135,7 @@ logger `shouldBe` "MyLogger" level `shouldBe` "INFO" - filterer == [Filter "Module.Submodule" 16] `shouldBe` True + filterer == ["Module.Submodule"] `shouldBe` True length handlers `shouldBe` 2 -- deep test handlers disabled `shouldBe` False propagate `shouldBe` False @@ -166,7 +169,7 @@ propagate `shouldBe` False disabled `shouldBe` False length filterer `shouldBe` 1 - filterer == [Filter "MyLogger.Main" 13] `shouldBe` True + filterer == ["MyLogger.Main"] `shouldBe` True length handlers `shouldBe` 2 diff --git a/test/LoggingSpec.hs b/test/LoggingSpec.hs --- a/test/LoggingSpec.hs +++ b/test/LoggingSpec.hs @@ -143,13 +143,13 @@ ] -createPipeHandler :: Level -> Filterer -> Formatter -> IO (HandlerT, Handle) +createPipeHandler :: Level -> Filterer -> Formatter -> IO (SomeHandler, Handle) createPipeHandler level filterer formatter = do lock <- newMVar () (read, write) <- createPipe hSetEncoding read utf8 hSetEncoding write utf8 - return $ ( HandlerT $ StreamHandler write level filterer formatter lock + return $ ( toHandler $ StreamHandler write level filterer formatter lock , read )