di 0.1 → 0.2

raw patch · 6 files changed

+586/−353 lines, 6 filesdep +QuickCheckdep +bytestringdep +didep −textdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, bytestring, di, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: text

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +37/−1
• di.cabal +21/−4
• src/Di.hs +42/−348
• src/Di/Backend.hs +73/−0
• src/Di/Core.hs +277/−0
• test/Main.hs +136/−0

@@ -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. 

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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