diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,40 @@ +# Version 0.2 + +* BREAKING CHANGE: `Di` now takes a new type argument `level`. + +* BREAKING CHANGE: Remove `Level` and all related functions in favour of a + new `level` argument to `Di` to be implemented by the user. + +* BREAKING CHANGE: Require `Monoid` instance for the `path` type. + +* BREAKING CHANGE: Removed `level` function. Added `filter` function instead. + +* BREAKING CHANGE: Drop `mkDiTextStderr` and `mkDiTextFileHandle` in favour of + `mkDiStringHandle` and `mkDiStringStderr`. The rationale is that we are + already paying the costs of many `show` calls, and users of this library are + quite likely to use `String`s anyway (since they, too, are likely using `show` + results). We will bring back `Text` based `mkDiTextStderr` when we can make it + performant. + +* BREAKING CHANGE: Rename the `path` and `msg` functions to `contrapath` and + `contramsg`, flipping the order of their arguments so that the function comes + first (like in `contramap`). + +* BREAKING CHANGE: The `push` function now takes the `Di` value as second + argument. + +* Fix ISO8601 formatting of second fractions. + +* Export `flush`. + +* Stricter ordering of async messages. + +* Added tests. + +* Added a lot of documentation. + + # Version 0.1 -Initial version. +* Initial version. diff --git a/di.cabal b/di.cabal --- a/di.cabal +++ b/di.cabal @@ -1,15 +1,16 @@ name: di -version: 0.1 +version: 0.2 author: Renzo Carbonara maintainer: renλren.zone copyright: Renzo Carbonara 2017 license: BSD3 license-file: LICENSE.txt extra-source-files: README.md CHANGELOG.md -category: Data +category: Logging build-type: Simple cabal-version: >=1.18 -synopsis: Easy and powerful typeful logging without monad towers. +synopsis: Easy, powerful, structured and typeful logging without monad towers. +description: Easy, powerful, structured and typeful logging without monad towers. homepage: https://github.com/k0001/di bug-reports: https://github.com/k0001/di/issues @@ -17,6 +18,22 @@ hs-source-dirs: src default-language: Haskell2010 exposed-modules: Di - build-depends: base >=4.9 && <5.0, stm, text, time, transformers + other-modules: Di.Core Di.Backend + build-depends: base >=4.9 && <5.0, stm, time, transformers ghcjs-options: -Wall -O3 ghc-options: -Wall -O2 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + bytestring, + di, + stm, + QuickCheck, + tasty, + tasty-hunit, + tasty-quickcheck diff --git a/src/Di.hs b/src/Di.hs --- a/src/Di.hs +++ b/src/Di.hs @@ -1,372 +1,66 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Intended module usage: +-- | -- +-- Import this module as follows: +-- -- @ -- import Di (Di) -- import qualified Di -- @ + module Di - ( Di - , mkDi + ( -- * Usage + -- $usage + Di + , log + , flush , push - , path - , msg - , level - , Level(DBG, INF, WRN, ERR) - -- * Synchronous logging - , dbg - , inf - , wrn - , err - -- * Asynchronous logging - , dbg' - , inf' - , wrn' - , err' + , filter + , contralevel + , contrapath + , contramsg -- * Backends - , mkDiTextStderr - , mkDiTextFileHandle + , mkDi + , B.mkDiStringStderr + , B.mkDiStringHandle ) where -import Control.Concurrent (forkIO, forkFinally, myThreadId) -import Control.Concurrent.STM -import qualified Control.Exception as Ex -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Monoid (mconcat, mappend, (<>)) -import Data.String (IsString(fromString)) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import qualified Data.Time as Time -import qualified System.IO as IO +import Prelude hiding (filter, log) --------------------------------------------------------------------------------- +import Di.Core + (Di, log, flush, push, filter, contralevel, contrapath, contramsg, mkDi) +import qualified Di.Backend as B --- | @'Di' path msg@ allows you to to log messages of type @msg@, under a scope --- identified by @path@ (think of @path@ as a filesystem path). --- --- Each @msg@ gets logged together with its 'Level', @path@ and the --- 'Time.UTCTime' timestamp stating when the logging requests was made. --- --- Even though logging is usually associated with rendering text, 'Di' makes no --- assumption about the types of the @msg@ values being logged, nor the @path@ --- values that convey their scope. Instead, it delays conversion from these --- precise types into the ultimately desired raw representation as much as --- possible. This makes it possible to log more precise information (for --- example, logging a datatype of your own without having to convert it to text --- first), richer scope paths (for example, the scope could be a --- 'Data.Map.Strict.Map' that gets enriched with more information as we 'push' --- down the @path@). This improves type safety, as well as the composability of --- the @path@ and @msg@ values. In particular, @path@ and @msg@ are --- contravariant values (see the 'path' and 'msg' functions). --- --- Contrary to other logging approaches based on monadic interfaces, a 'Di' is a --- value that is expected to be passed around explicitly. A 'Di' can be safely --- used concurrently, and messages are rendered in the order they were submitted --- for logging, both in the case of synchronous logging (e.g., 'err') and --- asynchronous logging (e.g., 'err''). --- --- 'Di' is pronounced as \"dee" (not \"die" nor \"dye" nor \"day"). \"Di" is --- the spanish word for an imperative form of the verb \"decir", which in --- english means "to say". -data Di path msg = forall path'. Monoid path' => Di - { _diLog :: Level -> Time.UTCTime -> path' -> msg -> IO () - -- ^ Low level logging function. - , _diPathMap :: path -> path' - -- ^ Used to implement the 'path' function while preserving the 'Monoid' - -- semantics of the @path'@ type. - , _diMinLevel :: Level - -- ^ Minimum level that we are allowed to log. - , _diLogs :: TQueue (IO ()) - -- ^ Work queue. This queue keeps fully applied '_diLog' calls. - } --- | Build a 'Di' from a logging function. -mkDi - :: (MonadIO m, Monoid path) - => (Level -> Time.UTCTime -> path -> msg -> IO ()) - -> m (Di path msg) -- ^ -mkDi f = liftIO $ do - di <- Di f id minBound <$> newTQueueIO - me <- myThreadId - _ <- forkFinally (worker di) (either (Ex.throwTo me) pure) - pure di - where - worker :: Di path msg -> IO () - worker di = do - eio <- Ex.try $ atomically $ do - io <- peekTQueue (_diLogs di) - pure (Ex.finally io (atomically (readTQueue (_diLogs di)))) - case eio of - Left (_ :: Ex.BlockedIndefinitelyOnSTM) -> do - pure () -- Nobody writes to '_diLogs' anymore, so we can just stop. - Right io -> do - catchSync io $ \se -> do - ts <- fmap renderIso8601 Time.getCurrentTime - IO.hPutStrLn IO.stderr $ mconcat - [ "ERR ", ts, " Di: could not log message at due to: " - , Ex.displayException se ] - worker di - --- | Block until all messages being logged have finished processing. -diFlush :: MonadIO m => Di path msg -> m () -diFlush di = liftIO $ atomically $ check =<< isEmptyTQueue (_diLogs di) -{-# INLINE diFlush #-} - --- | Asynchronously log a message with the given 'Level' by queueing it in FIFO --- order to be logged in a different thread as soon as possible. The timestamp --- of the logged message will correctly represent the time of the 'diAsync' --- call. --- --- /WARNING/ This function returns immediately, which makes it ideal for usage --- in tight loops. However, if logging the message fails later, you won't be --- able to catch the relevant exception. -diAsync :: MonadIO m => Di path msg -> Level -> msg -> m () -diAsync (Di dLog _ dMinLevel dLogs) l m - | l < dMinLevel = pure () - | otherwise = liftIO $ void $ forkIO $ do - ts <- Time.getCurrentTime - atomically $ writeTQueue dLogs (dLog l ts mempty m) -{-# INLINABLE diAsync #-} - --- | Log a message with the given 'Level'. -diSync :: MonadIO m => Di path msg -> Level -> msg -> m () -diSync di l m = diAsync di l m >> diFlush di -{-# INLINABLE diSync #-} - --- | Push a new @path@ to the 'Di'. --- --- The passed in 'Di' can continue to be used even after using 'push' or the --- returned 'Di'. --- --- See 'mkDiTextStderr' for an example behaviour. -push :: Di path msg -> path -> Di path msg -push (Di dLog dPathMap dMinLevel dLogs) p0 = - let dLog' = \l ts p1 m -> dLog l ts (dPathMap p0 <> p1) m - in Di dLog' dPathMap dMinLevel dLogs -{-# INLINABLE push #-} - --- | A 'Di' is contravariant in its @path@ argument. --- --- This function is used to go from a /more general/ to a /more specific/ type --- of @path@. For example, @['Int']@ is a more specific type than @['String']@, --- since the former clearly conveys the idea of a list of numbers, whereas the --- latter could be a list of anything that is representable as 'String', such as --- dictionary words. We can convert from the more general to the more specific --- @path@ type using this 'path' function: +-- $usage -- --- @ --- 'path' (x :: 'Di' ['String'] msg) ('map' 'show') :: 'Di' ['Int'] msg --- @ +-- First, read the documentation for the 'Di' datatype. -- --- The 'Monoid'al behavior of the original @path'@ is preserved in the resulting --- 'Di'. -path :: Di path' msg -> (path -> path') -> Di path msg -path (Di dLog dPathMap dMinLevel dLogs) f = - Di dLog (dPathMap . f) dMinLevel dLogs -{-# INLINABLE path #-} - --- | A 'Di' is contravariant in its @msg@ argument. +-- Second, create a base 'Di' value. You will achieve this by using 'mkDi' or, +-- more likely, one of the ready-made 'B.mkDiStringStderr', +-- 'B.mkDiStringHandle', etc. -- --- This function is used to go from a /more general/ to a /more specific/ type --- of @msg@. For example, @'Int'@ is a more specific type than @'String'@, since --- the former clearly conveys the idea of a numbers, whereas the latter could be --- a anything that is representable as 'String', such as a dictionary word. We --- can convert from the more general to the more specific @msg@ type using this --- 'msg' function: +-- At this point, you can start logging messages using 'log'. However, things +-- can be made more interesting. -- --- @ --- 'msg' (x :: 'Di' path 'String') 'show' :: 'Di' path 'Int' --- @ -msg :: Di path msg' -> (msg -> msg') -> Di path msg -msg (Di dLog dPathMap dMinLevel dLogs) f = - let dLog' = \l ts p m -> dLog l ts p (f m) - in Di dLog' dPathMap dMinLevel dLogs -{-# INLINABLE msg #-} - --- | Returns a new 'Di' on which messages below the given 'Level' are not --- logged, where ther ordering of levels is as follow: +-- Your choice of base 'Di' will mandate particular types for the @level@, +-- @path@ and @msg@ arguments to 'Di'. However, these base types are likely to +-- be very general (e.g., 'String'), so quite likely you'll want to use +-- 'contralevel', 'contrapath' and 'contramsg' to make those types more +-- specific. For example, you can use a precise datatype like the following for +-- associating each log message with a particular importance level: -- -- @ --- 'DBG' < 'INF' < 'WRN' < 'ERR' +-- data Level = Error | Info | Debug +-- deriving ('Show') -- @ -- --- For example, @'level' x 'WRN'@ will prevent 'DBG' and 'INF' from being logged. --- --- Notice that @'level' di x@ will allow messages with a level greater than or --- equal to @x@ even if they had been previously silenced in the given @di@. -level :: Di path msg -> Level -> Di path msg -level di l = di { _diMinLevel = l } - --------------------------------------------------------------------------------- - -data Level - = DBG -- ^ Debug - | INF -- ^ Info - | WRN -- ^ Warning - | ERR -- ^ Error - deriving (Eq, Ord, Enum, Bounded, Show, Read) - --------------------------------------------------------------------------------- - --- | Synchronously log a message with 'DBG' level. -dbg :: MonadIO m => Di path msg -> msg -> m () -dbg di = diSync di DBG - --- | Synchronously log a message with 'INF' level. -inf :: MonadIO m => Di path msg -> msg -> m () -inf di = diSync di INF - --- | Synchronously log a message with 'WRN' level. -wrn :: MonadIO m => Di path msg -> msg -> m () -wrn di = diSync di WRN - --- | Synchronously log a message with 'ERR' level. -err :: MonadIO m => Di path msg -> msg -> m () -err di = diSync di ERR - --------------------------------------------------------------------------------- - --- | Asynchronously log a message with 'DBG' level by queueing it in FIFO --- order to be logged in a different thread as soon as possible. The timestamp --- of the logged message will correctly represent the time of the 'dbg'' call. --- --- /WARNING/ This function returns immediately, which makes it ideal for usage --- in tight loops. However, if logging the message fails later, you won't be --- able to catch the relevant exception. -dbg' :: MonadIO m => Di path msg -> msg -> m () -dbg' di = diAsync di DBG - --- | Asynchronously log a message with 'INF' level by queueing it in FIFO --- order to be logged in a different thread as soon as possible. The timestamp --- of the logged message will correctly represent the time of the 'inf'' call. --- --- /WARNING/ This function returns immediately, which makes it ideal for usage --- in tight loops. However, if logging the message fails later, you won't be --- able to catch the relevant exception. -inf' :: MonadIO m => Di path msg -> msg -> m () -inf' di = diAsync di INF - --- | Asynchronously log a message with 'WRN' level by queueing it in FIFO --- order to be logged in a different thread as soon as possible. The timestamp --- of the logged message will correctly represent the time of the 'wrn'' call. --- --- /WARNING/ This function returns immediately, which makes it ideal for usage --- in tight loops. However, if logging the message fails later, you won't be --- able to catch the relevant exception. -wrn' :: MonadIO m => Di path msg -> msg -> m () -wrn' di = diAsync di WRN - --- | Asynchronously log a message with 'ERR' level by queueing it in FIFO --- order to be logged in a different thread as soon as possible. The timestamp --- of the logged message will correctly represent the time of the 'err'' call. --- --- /WARNING/ This function returns immediately, which makes it ideal for usage --- in tight loops. However, if logging the message fails later, you won't be --- able to catch the relevant exception. -err' :: MonadIO m => Di path msg -> msg -> m () -err' di = diAsync di ERR - --------------------------------------------------------------------------------- - -{- -test :: IO () -test = do - d0 <- mkDiTextStderr - dbg d0 "a" - let d1 = push d0 "f/oo" - inf' d1 "b" - let d2 = push d1 "b ar" - wrn d2 "c" - let d3 = push d2 "qux" - inf (level d3 WRN) "d" - err d0 "e\nf" - let d4 = push (path d3 (Text.pack . show)) [True,False] - err d4 "asd" - let d5 = push (msg d4 (Text.pack . show)) [] - err d5 True --} - --------------------------------------------------------------------------------- - --- | Strings separated by a forward slash. Doesn't contain white space. --- --- Use 'fromString' (GHC's @OverloadedStrings@ extension) to construct a --- 'TextPath'. -newtype TextPath = TextPath { unTextPath :: Text.Text } - deriving (Eq, Ord, Show) - -instance IsString TextPath where - fromString = textPathSingleton . Text.pack - -textPathSingleton :: Text.Text -> TextPath -textPathSingleton = TextPath . Text.map f - where f :: Char -> Char - f '/' = '.' - f ' ' = '_' - f '\n' = '_' - f '\r' = '_' - f c = c - -instance Monoid TextPath where - mempty = TextPath "" - mappend (TextPath "") b = b - mappend a (TextPath "") = a - mappend (TextPath a) (TextPath b) = TextPath (a <> "/" <> b) - --- | 'Text.Text' is written to 'IO.Handle' using the system's locale encoding. --- See 'mkDiTextStderr' for example output. -mkDiTextFileHandle - :: MonadIO m - => IO.Handle - -> m (Di Text.Text Text.Text) -mkDiTextFileHandle h = liftIO $ do - IO.hSetBuffering h IO.LineBuffering - fmap (flip path textPathSingleton) $ mkDi $ \l ts p m -> do - Text.hPutStrLn h $ mconcat - [ Text.pack (show l), " ", Text.pack (renderIso8601 ts) - , if p == mempty then "" else (" " <> unTextPath p) - , ": ", noBreaks m ] - IO.hFlush h - where - noBreaks :: Text.Text -> Text.Text - noBreaks = Text.concatMap $ \case - '\n' -> "\\n" - '\r' -> "\\r" - c -> Text.singleton c - --- | 'Text.Text' is written to 'IO.stderr' using the system's locale encoding. +-- Now, assuming the your base 'Di' @level@ type is 'String', you can use +-- @'contralevel' 'show'@ to convert your @'Di' 'String' path msg@ to a @'Di' +-- 'Level' path msg@. The same approach applies to @path@ and @msg@ as well, +-- through the 'contrapath' and 'contramsg' functions respectively. -- --- @ --- > d0 <- 'mkDiTextStderr' --- > 'dbg' d0 "a" --- __DBG 2017-05-06T19:01:27:306168750000Z: a__ --- > let d1 = push d0 "f\/oo" -- /\'\/' is converted to \'.'/ --- > 'inf' d1 "b" --- __INF 2017-05-06T19:01:27:314333636000Z f.oo: b__ --- > let d2 = push d1 "b ar" -- /\' ' is converted to \'_'/ --- > 'wrn' d2 "c" --- __WRN 2017-05-06T19:01:27:322092498000Z f.oo\/b_ar: c__ --- > let d3 = push d2 "qux" --- > 'err' d3 "d" --- __ERR 2017-05-06T19:01:27:326704385000Z f.oo\/b_ar\/qux: d__ --- > 'err' d0 "e\\nf" -- /d0, of course, still works/ --- __ERR 2017-05-06T19:01:27:823167007000Z: e\\nf__ --- @ -mkDiTextStderr :: MonadIO m => m (Di Text.Text Text.Text) -mkDiTextStderr = mkDiTextFileHandle IO.stderr - --------------------------------------------------------------------------------- - -renderIso8601 :: Time.UTCTime -> String -renderIso8601 = Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S:%qZ" +-- /Hint/: If you are building a library, be sure to export your @Level@ +-- datatype so that users of your library can 'contralevel' your 'Level' +-- datatype as necessary. -catchSync :: IO a -> (Ex.SomeException -> IO a) -> IO a -catchSync m f = Ex.catch m $ \se -> case Ex.asyncExceptionFromException se of - Just ae -> Ex.throwIO (ae :: Ex.AsyncException) - Nothing -> f se diff --git a/src/Di/Backend.hs b/src/Di/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Di/Backend.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE LambdaCase #-} + +module Di.Backend + ( mkDiStringStderr + , mkDiStringHandle + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Monoid (mconcat, mappend, (<>)) +import Data.String (IsString(fromString)) +import qualified Data.Time as Time +import Prelude hiding (log, filter) +import qualified System.IO as IO + +import Di.Core (Di, mkDi, contrapath) + +-------------------------------------------------------------------------------- + +-- | Strings separated by a forward slash. Doesn't contain white space. +-- +-- Use 'fromString' (GHC's @OverloadedStrings@ extension) to construct a +-- 'StringPath'. +newtype StringPath = StringPath { unStringPath :: String } + deriving (Eq, Ord, Show) + +instance IsString StringPath where + fromString = stringPathSingleton + {-# INLINE fromString #-} + +stringPathSingleton :: String -> StringPath +stringPathSingleton = \s -> StringPath (map f s) + where f :: Char -> Char + f = \case '/' -> '.' + ' ' -> '_' + '\n' -> '_' + '\r' -> '_' + c -> c + +instance Monoid StringPath where + mempty = StringPath "" + mappend (StringPath "") b = b + mappend a (StringPath "") = a + mappend (StringPath a) (StringPath b) = StringPath (a <> "/" <> b) + +-- | 'String's are written to 'IO.Handle' using the 'IO.Handle''s locale +-- encoding. +mkDiStringHandle + :: (MonadIO m) + => IO.Handle + -> m (Di String String String) +mkDiStringHandle h = liftIO $ do + IO.hSetBuffering h IO.LineBuffering + fmap (contrapath stringPathSingleton) $ mkDi $ \ts l p m -> do + IO.hPutStrLn h $ mconcat + [ l, " ", renderIso8601 ts + , if p == mempty then "" else (" " <> unStringPath p) + , ": ", noBreaks m ] + IO.hFlush h + where + noBreaks :: String -> String + noBreaks = concatMap $ \case + '\n' -> "\\n" + '\r' -> "\\r" + c -> [c] + +-- | 'String' is written to 'IO.stderr' using the system's locale encoding. +mkDiStringStderr :: MonadIO m => m (Di String String String) +mkDiStringStderr = mkDiStringHandle IO.stderr + +-------------------------------------------------------------------------------- + +renderIso8601 :: Time.UTCTime -> String +renderIso8601 = Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S.%qZ" diff --git a/src/Di/Core.hs b/src/Di/Core.hs new file mode 100644 --- /dev/null +++ b/src/Di/Core.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Di.Core + ( Di(..) + , mkDi + , log + , flush + , push + , filter + , contralevel + , contrapath + , contramsg + ) where + +import Control.Concurrent (forkFinally, myThreadId) +import Control.Concurrent.STM +import qualified Control.Exception as Ex +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Function (fix) +import Data.Monoid (mconcat, (<>)) +import qualified Data.Time as Time +import Prelude hiding (log, filter) +import qualified System.IO as IO + +-------------------------------------------------------------------------------- + +-- | @'Di' level path msg@ allows you to to log messages of type @msg@, with a +-- particular importance @level@, under a scope identified by @path@ (think of +-- @path@ as a filesystem path that you can use to group together related log +-- messages). +-- +-- Each @msg@ gets logged together with its @level@, @path@ and the +-- 'Time.UTCTime' stating the instant when the logging requests was made. +-- +-- Even though logging is usually associated with rendering text, 'Di' makes no +-- assumption about the types of the @msg@ values being logged, nor the @path@ +-- values that convey their scope, nor the @level@ values that convey their +-- importance. Instead, it delays conversion from these precise types into the +-- ultimately desired raw representation (if any) as much as possible. This +-- makes it possible to log more precise information (for example, logging a +-- datatype of your own without having to convert it to text first), richer +-- scope paths (for example, the scope could be a 'Data.Map.Strict.Map' that +-- gets enriched with more information as we 'push' down the @path@), and +-- importance @level@s that are never too broad nor too narrow. This improves +-- type safety, as well as the composability of the @level@, @path@ and @msg@ +-- values. In particular, all of @level@, @path@ and @msg@ are contravariant +-- values, which in practice means including a precise 'Di' into a more general +-- 'Di' is always possible (see the 'contralevel@, 'contrapath' and 'contramsg' +-- functions). +-- +-- Messages of undesired importance levels can be muted by using 'filter'. +-- +-- Contrary to other logging approaches based on monad transformers, a 'Di' is a +-- value that is expected to be passed around explicitly. Of course, if +-- necessary you can always put a 'Di' in some internal monad state or +-- environment and provide a custom API for it. That's a choice you can make. +-- +-- A 'Di' can be safely used concurrently, and messages are rendered in the +-- absolute order they were submitted for logging. +-- +-- 'Di' is pronounced as \"dee" (not \"die" nor \"dye" nor \"day"). \"Di" is +-- the spanish word for an imperative form of the verb \"decir", which in +-- english means "to say". +data Di level path msg = Di + { _diLog :: Time.UTCTime -> level -> path -> msg -> IO () + -- ^ Low level logging function. + , _diFilter :: level -> Bool + -- ^ Whether a particular message @level@ should be logged or not. + , _diLogs :: TQueue (IO ()) + -- ^ Work queue. This queue keeps fully applied '_diLog' calls. + } + +-- | Build a new 'Di' from a logging function. +-- +-- /Note:/ If the passed in 'IO' function throws a exception, it will be +-- just logged to 'IO.stderr' and then ignored. +-- +-- /Note:/ There's no need to "release" the obtained 'Di'. +mkDi + :: MonadIO m + => (Time.UTCTime -> level -> path -> msg -> IO ()) + -> m (Di level path msg) -- ^ +mkDi f = liftIO $ do + di <- Di f (const True) <$> newTQueueIO + me <- myThreadId + _ <- forkFinally (worker di) (either (Ex.throwTo me) pure) + pure di + where + worker :: Di level path msg -> IO () + worker di = fix $ \k -> do + eio <- Ex.try $ atomically $ do + io <- peekTQueue (_diLogs di) + pure (Ex.finally io (atomically (readTQueue (_diLogs di)))) + case eio of + Left (_ :: Ex.BlockedIndefinitelyOnSTM) -> do + pure () -- Nobody writes to '_diLogs' anymore, so we can just stop. + Right io -> do + catchSync io $ \se -> do + ts <- fmap renderIso8601 Time.getCurrentTime + IO.hPutStrLn IO.stderr $ mconcat + [ "Logging error at ", ts + , ": could not log message at due to " + , Ex.displayException se, ". Ignoring." ] + k + +-- | Log a message with the given importance @level@. +-- +-- This function returns immediately after queing the message for logging in a +-- different thread. If you want to explicitly wait for the message to be +-- logged, then call 'flush' afterwards. +-- +-- /Note:/ No exceptions from the underlying logging backend (i.e., the 'IO' +-- action given to 'mkDi') will be thrown from 'log'. Instead, those will be +-- recorded to 'IO.stderr' and ignored. +log :: (MonadIO m, Monoid path) => Di level path msg -> level -> msg -> m () +log (Di dLog dFilter dLogs) !l = \(!m) -> + when (dFilter l) $ liftIO $ do + ts <- Time.getCurrentTime + atomically $ writeTQueue dLogs $! dLog ts l mempty m +{-# INLINABLE log #-} + + +-- | Block until all messages being logged have finished processing. +-- +-- Mabually calling 'flush' is not usually necessary, but, if at some point you +-- want to ensure that all messages logged until then have properly rendered to +-- the underlying backend, then 'flush' will block until that happens. +flush :: MonadIO m => Di level path msg -> m () +flush di = liftIO (atomically (check =<< isEmptyTQueue (_diLogs di))) +{-# INLINABLE flush #-} + + +-- | Returns a new 'Di' on which only messages with a @level@ satisfying the +-- given predicate—in addition to any previous 'filter's—are ever logged. +-- +-- Identity: +-- +-- @ +-- 'filter' ('const' 'True') == 'id' +-- @ +-- +-- Composition: +-- +-- @ +-- 'filter' ('Control.Applicative.liftA2' (&&) f g) == 'filter' f . 'filter' g +-- @ +-- +-- Conmutativity: +-- +-- @ +-- 'filter' f . 'filter' g == 'filter' g . 'filter' f +-- @ +filter :: (level -> Bool) -> Di level path msg -> Di level path msg +filter f = \di -> di { _diFilter = \l -> f l && _diFilter di l } +{-# INLINABLE filter #-} + + +-- | Push a new @path@ to the 'Di'. +-- +-- Identity: +-- +-- @ +-- 'push' 'mempty' == 'id' +-- @ +-- +-- Composition: +-- +-- @ +-- 'push' (a <> b) == 'push' b . 'push' a +-- @ +push :: Monoid path => path -> Di level path msg -> Di level path msg +push ps = \(Di dLog dFilter dLogs) -> + Di (\ts l p1 m -> dLog ts l (ps <> p1) m) dFilter dLogs +{-# INLINABLE push #-} + + +-- | A 'Di' is contravariant in its @level@ argument. +-- +-- This function is used to go from a /more general/ to a /less general/ type +-- of @level@. For example, @data Level = Info | Error@ is a less general type +-- than @data Level' = Info' | Warning' | Error'@, since the former can only +-- convey two logging levels, whereas the latter can convey three. We can +-- convert from the more general to the less general @level@ type using this +-- 'contralevel' function: +-- +-- @ +-- 'contralevel' (\\case { Info -> Info'; Error -> Error' }) (di :: 'Di' Level' ['String'] msg) +-- :: 'Di' Level ['Int'] msg +-- @ +-- +-- Identity: +-- +-- @ +-- 'contralevel' 'id' == 'id' +-- @ +-- +-- Composition: +-- +-- @ +-- 'contralevel' (f . g) == 'contralevel' g . 'contralevel' f +-- @ +contralevel :: (level -> level') -> Di level' path msg -> Di level path msg +contralevel f = \(Di dLog dFilter dLogs) -> + Di (\ts l p m -> dLog ts (f l) p m) (\l -> dFilter (f l)) dLogs +{-# INLINABLE contralevel #-} + +-- | A 'Di' is contravariant in its @path@ argument. +-- +-- This function is used to go from a /more general/ to a /less specific/ type +-- of @path@. For example, @['Int']@ is a less general type than @['String']@, +-- since the former clearly conveys the idea of a list of numbers, whereas the +-- latter could be a list of anything that is representable as 'String', such as +-- names of fruits and poems. We can convert from the more general to the less +-- general @path@ type using this 'contrapath' function: +-- +-- @ +-- 'contrapath' ('map' 'show') (di :: 'Di' level ['String'] msg) +-- :: 'Di' ['Int'] msg +-- @ +-- +-- Identity: +-- +-- @ +-- 'contrapath' 'id' == 'id' +-- @ +-- +-- Composition: +-- +-- @ +-- 'contrapath' (f . g) == 'contrapath' g . 'contrapath' f +-- @ +contrapath :: (path -> path') -> Di level path' msg -> Di level path msg +contrapath f = \(Di dLog dFilter dLogs) -> + Di (\ts l p m -> dLog ts l (f p) m) dFilter dLogs +{-# INLINABLE contrapath #-} + +-- | A 'Di' is contravariant in its @msg@ argument. +-- +-- This function is used to go from a /more general/ to a /less general/ type +-- of @msg@. For example, @'Int'@ is a less general type than @'String'@, since +-- the former clearly conveys the idea of a numbers, whereas the latter could be +-- a anything that is representable as 'String', such as names of painters and +-- colors. We can convert from the more general to the less general @msg@ type +-- using this 'contramsg' function: +-- +-- @ +-- 'contramsg' 'show' (di :: 'Di' level path 'String') +-- :: 'Di' level path 'Int' +-- @ +-- +-- Identity: +-- +-- @ +-- 'contramsg' 'id' == 'id' +-- @ +-- +-- Composition: +-- +-- @ +-- 'contramsg' (f . g) == 'contramsg' g . 'contramsg' f +-- @ +contramsg :: (msg -> msg') -> Di level path msg' -> Di level path msg +contramsg f = \(Di dLog dFilter dLogs) -> + Di (\ts l p m -> dLog ts l p (f m)) dFilter dLogs +{-# INLINABLE contramsg #-} + +-------------------------------------------------------------------------------- + +renderIso8601 :: Time.UTCTime -> String +renderIso8601 = Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S.%qZ" + +catchSync :: IO a -> (Ex.SomeException -> IO a) -> IO a +catchSync m f = Ex.catch m $ \se -> case Ex.asyncExceptionFromException se of + Just ae -> Ex.throwIO (ae :: Ex.AsyncException) + Nothing -> f se diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Control.Applicative (liftA2) +import qualified Control.Exception as Ex +import Control.Concurrent.STM + (STM, atomically, TQueue, newTQueue, writeTQueue, tryReadTQueue) +import Data.Foldable (for_) +import Data.Function (fix) +import Data.Monoid (Sum(Sum, getSum)) +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.HUnit ((@?=)) +import qualified Test.Tasty.QuickCheck as QC +import qualified Test.Tasty.Runners as Tasty + +import Di (Di) +import qualified Di + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] tt + +tt :: Tasty.TestTree +tt = Tasty.testGroup "di" + [ QC.testProperty "log" $ do + QC.forAll QC.arbitrary $ \lpms -> + QC.ioProperty $ do + expect lpms $ \di0 -> do + for_ lpms $ \(l, p, m) -> do + Di.log (Di.push p di0) l m + + , HU.testCase "push" $ do + let x = [("","",""), ("","",""), ("","1",""), ("","12",""), ("","12",""), ("","","")] + expect x $ \di0 -> do + Di.log di0 "" "" + -- Identity + Di.log (Di.push "" di0) "" "" + -- Composition + Di.log (Di.push "1" di0) "" "" + Di.log ((Di.push "2" . Di.push "1") di0) "" "" + Di.log (Di.push "12" di0) "" "" + -- Checking that di0 still works + Di.log di0 "" "" + + , HU.testCase "contralevel" $ do + let x = [("1","",""), ("1","",""), ("1","",""), ("2","",""), ("2","",""), ("1","","")] + n = 1 :: Int + expect x $ \di0 -> do + Di.log di0 "1" "" + -- Identity + Di.log (Di.contralevel id di0) "1" "" + -- Composition + Di.log (Di.contralevel show di0) n "" + Di.log ((Di.contralevel succ . Di.contralevel show) di0) n "" + Di.log (Di.contralevel (show . succ) di0) n "" + -- Checking that di0 still works + Di.log di0 "1" "" + + , HU.testCase "contrapath" $ do + let x = [("","",""), ("","1",""), ("","1",""), ("","1",""), ("","2",""), ("","2",""), ("","","")] + n = Sum (1 :: Int) + expect x $ \di0 -> do + Di.log di0 "" "" + Di.log (Di.push "1" di0) "" "" + -- Identity + Di.log (Di.push "1" (Di.contrapath id di0)) "" "" + -- Composition + Di.log (Di.push n (Di.contrapath (show . getSum) di0)) "" "" + Di.log (Di.push n ((Di.contrapath (mappend n) . Di.contrapath (show . getSum)) di0)) "" "" + Di.log (Di.push n (Di.contrapath (show . getSum . mappend n) di0)) "" "" + -- Checking that di0 still works + Di.log di0 "" "" + + , HU.testCase "contramsg" $ do + let x = [("","","1"), ("","","1"), ("","","1"), ("","","2"), ("","","2"), ("","","1")] + n = 1 :: Int + expect x $ \di0 -> do + Di.log di0 "" "1" + -- Identity + Di.log (Di.contramsg id di0) "" "1" + -- Composition + Di.log (Di.contramsg show di0) "" n + Di.log ((Di.contramsg succ . Di.contramsg show) di0) "" n + Di.log (Di.contramsg (show . succ) di0) "" n + -- Checking that di0 still works + Di.log di0 "" "1" + + , HU.testCase "filter" $ do + let x = [("1","","a"), ("2","","c"), ("1","","d"), ("3","","g"), ("3","","j"), ("3","","m"), ("1","","n")] + expect x $ \di0 -> do + Di.log di0 "1" "a" + -- Predicates + Di.log (Di.filter (/= "1") di0) "1" "b" + Di.log (Di.filter (/= "1") di0) "2" "c" + -- Identity + Di.log (Di.filter (const True) di0) "1" "d" + -- Composition + Di.log ((Di.filter (/= "1") . Di.filter (/= "2")) di0) "1" "e" + Di.log ((Di.filter (/= "1") . Di.filter (/= "2")) di0) "2" "f" + Di.log ((Di.filter (/= "1") . Di.filter (/= "2")) di0) "3" "g" + Di.log (Di.filter (liftA2 (&&) (/= "1") (/= "2")) di0) "1" "h" + Di.log (Di.filter (liftA2 (&&) (/= "1") (/= "2")) di0) "2" "i" + Di.log (Di.filter (liftA2 (&&) (/= "1") (/= "2")) di0) "3" "j" + -- Conmutativity (c.f., "e" "f" "g") + Di.log ((Di.filter (/= "2") . Di.filter (/= "1")) di0) "1" "k" + Di.log ((Di.filter (/= "2") . Di.filter (/= "1")) di0) "2" "l" + Di.log ((Di.filter (/= "2") . Di.filter (/= "1")) di0) "3" "m" + -- Checking that di0 still works + Di.log di0 "1" "n" + ] + +expect :: [(String, String, String)] -> (Di String String String -> IO a) -> IO a +expect as0 k = Ex.bracket + (do tq <- atomically newTQueue + di <- Di.mkDi (\_ l p m -> atomically (writeTQueue tq (l, p, m))) + pure (tq, di)) + (\(tq, di) -> do + Di.flush di + as1 <- atomically (drainTQueue tq) + as1 @?= as0) + (\(_, di) -> k di) + +drainTQueue :: TQueue a -> STM [a] +drainTQueue tq = do + let go as = maybe (pure as) (\a -> go (a:as)) =<< tryReadTQueue tq + fmap reverse (go []) + +#if !MIN_VERSION_QuickCheck(2,10,0) +instance QC.Testable () where + property () = QC.property True +#endif