di (empty) → 0.1

raw patch · 6 files changed

+444/−0 lines, 6 filesdep +basedep +stmdep +textsetup-changed

Dependencies added: base, stm, text, time, transformers

Files

• CHANGELOG.md +4/−0
• LICENSE.txt +30/−0
• README.md +12/−0
• Setup.hs +4/−0
• di.cabal +22/−0
• src/Di.hs +372/−0

@@ -0,0 +1,4 @@+# Version 0.1++Initial version.+

@@ -0,0 +1,30 @@+Copyright (c) 2017, Renzo Carbonara++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Renzo Carbonara nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,12 @@+# di++Easy and powerful typeful logging without monad towers.++[![Build Status](https://travis-ci.org/k0001/di.svg?branch=master)](https://travis-ci.org/k0001/di)++See the [BSD3 LICENSE](https://github.com/k0001/di/blob/master/di/LICENSE.txt)+file to learn about the legal terms and conditions for this library.++Find documentation for this library in the top-level+[`Di`](https://github.com/k0001/di/blob/master/di/src/Di.hs) module.+

@@ -0,0 +1,4 @@+#! /usr/bin/env nix-shell+#! nix-shell ./shell.nix -i runghc+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,22 @@+name: di+version: 0.1+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+build-type: Simple+cabal-version: >=1.18+synopsis: Easy and powerful typeful logging without monad towers.+homepage: https://github.com/k0001/di+bug-reports: https://github.com/k0001/di/issues++library+  hs-source-dirs: src+  default-language: Haskell2010+  exposed-modules: Di+  build-depends: base >=4.9 && <5.0, stm, text, time, transformers+  ghcjs-options: -Wall -O3+  ghc-options: -Wall -O2

@@ -0,0 +1,372 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Intended module usage:+--+-- @+-- import Di (Di)+-- import qualified Di+-- @++module Di+ ( Di+ , mkDi+ , push+ , path+ , msg+ , level+ , Level(DBG, INF, WRN, ERR)+   -- * Synchronous logging+ , dbg+ , inf+ , wrn+ , err+   -- * Asynchronous logging+ , dbg'+ , inf'+ , wrn'+ , err'+   -- * Backends+ , mkDiTextStderr+ , mkDiTextFileHandle+ ) 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++--------------------------------------------------------------------------------++-- | @'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:+--+-- @+-- 'path' (x :: 'Di' ['String'] msg) ('map' 'show') :: 'Di' ['Int'] msg+-- @+--+-- 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.+--+-- 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:+--+-- @+-- '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:+--+-- @+-- 'DBG' < 'INF' < 'WRN' < 'ERR'+-- @+--+-- 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.+--+-- @+-- > 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"++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