packages feed

log4hs 0.0.5.0 → 0.0.6.0

raw patch · 7 files changed

+294/−126 lines, 7 filesdep +criteriondep +generic-lensdep +lensdep ~aesondep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion, generic-lens, lens

Dependency ranges changed: aeson, containers

API changes (from Hackage documentation)

- Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (Data.Map.Internal.Map GHC.Base.String Logging.Types.Formatter -> GHC.Types.IO Logging.Types.HandlerT)
- Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Base.String -> Data.Map.Internal.Map GHC.Base.String Logging.Types.HandlerT -> Logging.Types.Sink)
- Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Types.IO Logging.Types.HandlerT)
- Logging.Types: [$sel:name:Filter] :: Filter -> String
- Logging.Types: [$sel:nlen:Filter] :: Filter -> Int
- Logging.Types: [HandlerT] :: Handler a => a -> HandlerT
- Logging.Types: acquire :: Handler a => a -> IO ()
- Logging.Types: data Filter
- Logging.Types: data HandlerT
- Logging.Types: getFilterer :: Handler a => a -> Filterer
- Logging.Types: getFormatter :: Handler a => a -> Formatter
- Logging.Types: getLevel :: Handler a => a -> Level
- Logging.Types: instance Language.Haskell.TH.Syntax.Lift Logging.Types.Level
- Logging.Types: release :: Handler a => a -> IO ()
- Logging.Types: setFilterer :: Handler a => a -> Filterer -> a
- Logging.Types: setFormatter :: Handler a => a -> Formatter -> a
- Logging.Types: setLevel :: Handler a => a -> Level -> a
- Logging.Types: with :: Handler a => a -> (a -> IO b) -> IO b
+ Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (Data.Map.Internal.Map GHC.Base.String Logging.Types.Formatter -> GHC.Types.IO Logging.Types.SomeHandler)
+ Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Base.String -> Data.Map.Internal.Map GHC.Base.String Logging.Types.SomeHandler -> Logging.Types.Sink)
+ Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Types.IO Logging.Types.SomeHandler)
+ Logging.Types: [SomeHandler] :: Handler h => h -> SomeHandler
+ Logging.Types: data SomeHandler
+ Logging.Types: fromHandler :: Handler a => SomeHandler -> Maybe a
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Filterer Logging.Types.SomeHandler
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Formatter Logging.Types.SomeHandler
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Level Logging.Types.SomeHandler
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Lock Logging.Types.SomeHandler
+ Logging.Types: instance GHC.Generics.Generic Logging.Types.StreamHandler
+ Logging.Types: instance GHC.Read.Read Logging.Types.Filter
+ Logging.Types: instance GHC.Show.Show Logging.Types.Filter
+ Logging.Types: instance Logging.Types.Handler Logging.Types.SomeHandler
+ Logging.Types: newtype Filter
+ Logging.Types: toHandler :: Handler a => a -> SomeHandler
- Logging.Types: Filter :: String -> Int -> Filter
+ Logging.Types: Filter :: Logger -> Filter
- Logging.Types: Sink :: Logger -> Level -> Filterer -> [HandlerT] -> Bool -> Bool -> Sink
+ Logging.Types: Sink :: Logger -> Level -> Filterer -> [SomeHandler] -> Bool -> Bool -> Sink
- Logging.Types: StreamHandler :: Handle -> Level -> Filterer -> Formatter -> MVar () -> StreamHandler
+ Logging.Types: StreamHandler :: Handle -> Level -> Filterer -> Formatter -> Lock -> StreamHandler
- Logging.Types: [$sel:handlers:Sink] :: Sink -> [HandlerT]
+ Logging.Types: [$sel:handlers:Sink] :: Sink -> [SomeHandler]
- Logging.Types: [$sel:lock:StreamHandler] :: StreamHandler -> MVar ()
+ Logging.Types: [$sel:lock:StreamHandler] :: StreamHandler -> Lock
- Logging.Types: class Handler a
+ Logging.Types: class (HasType Level a, HasType Filterer a, HasType Formatter a, HasType Lock a, Typeable a) => Handler a

Files

+ bench/Main.hs view
@@ -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"+    }+  }|]+
log4hs.cabal view
@@ -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
src/Logging/Aeson.hs view
@@ -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
src/Logging/Internal.hs view
@@ -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
src/Logging/Types.hs view
@@ -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))
test/Logging/AesonSpec.hs view
@@ -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  
test/LoggingSpec.hs view
@@ -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            )