co-log 0.2.0 → 0.3.0.0

raw patch · 18 files changed

+1010/−284 lines, 18 filesdep +chronosdep +hedgehogdep −timedep ~ansi-terminaldep ~basedep ~co-log-corenew-component:exe:tutorial-customnew-component:exe:tutorial-introPVP ok

version bump matches the API change (PVP)

Dependencies added: chronos, hedgehog

Dependencies removed: time

Dependency ranges changed: ansi-terminal, base, co-log-core, mtl, typerep-map

API changes (from Hackage documentation)

Files

• CHANGELOG.md +25/−2
• README.lhs +2/−0
• README.md +105/−0
• co-log.cabal +74/−55
• example/Main.hs +0/−122
• src/Colog.hs +9/−0
• src/Colog/Actions.hs +68/−11
• src/Colog/Concurrent.hs +36/−29
• src/Colog/Concurrent/Internal.hs +15/−8
• src/Colog/Contra.hs +17/−3
• src/Colog/Message.hs +112/−47
• src/Colog/Monad.hs +14/−1
• src/Colog/Pure.hs +8/−1
• src/Colog/Rotation.hs +16/−5
• test/Property.hs +64/−0
• tutorials/1-intro/Intro.lhs +122/−0
• tutorials/2-custom/Custom.lhs +135/−0
• tutorials/Main.hs +188/−0

@@ -1,7 +1,30 @@-# Change log+# Changelog  `co-log` uses [PVP Versioning][1].-The change log is available [on GitHub][2].+The changelog is available [on GitHub][2].++## 0.3.0.0 — May 5, 2019++* [#77](https://github.com/kowainik/co-log/issues/77):+  **Important:** Use `chronos` time formatter. This is a breaking change because+  default field map in `RichMessage` now contains different type representing+  time. If you use your custom formatter for time, you should change it.+  Othwerwise no observable differences in the library API usage will be noticed.+* [#103](https://github.com/kowainik/co-log/issues/103):+  **Breaking change:** make `Message` data type polymorhic over the type of severity.++  **Migration guide:** this change is done in backwards-compatible way. If you+  use any fields of the `Message` data type, you should rename them according to+  the following scheme:+  ```haskell+  messageSeverity -> msgSeverity+  messageStack    -> msgStack+  messageText     -> msgText+  ```+* Export more formatting functions to make implementation of custom formatters easier.+* [#96](https://github.com/kowainik/co-log/issues/96):+  Add `simpleMessageAction` and `richMessageAction` to work with `Message`s.+* Use `co-log-core` of version `0.2.0.0`.  ## 0.2.0 — Nov 15, 2018 

@@ -1,6 +1,8 @@ # co-log  [![Hackage](https://img.shields.io/hackage/v/co-log.svg)](https://hackage.haskell.org/package/co-log)+[![Stackage LTS](http://stackage.org/package/co-log/badge/lts)](http://stackage.org/lts/package/co-log)+[![Stackage Nightly](http://stackage.org/package/co-log/badge/nightly)](http://stackage.org/nightly/package/co-log) [![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/co-log/blob/master/LICENSE) [![Build status](https://secure.travis-ci.org/kowainik/co-log.svg)](https://travis-ci.org/kowainik/co-log) 

@@ -0,0 +1,105 @@+# co-log++[![Hackage](https://img.shields.io/hackage/v/co-log.svg)](https://hackage.haskell.org/package/co-log)+[![Stackage LTS](http://stackage.org/package/co-log/badge/lts)](http://stackage.org/lts/package/co-log)+[![Stackage Nightly](http://stackage.org/package/co-log/badge/nightly)](http://stackage.org/nightly/package/co-log)+[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/co-log/blob/master/LICENSE)+[![Build status](https://secure.travis-ci.org/kowainik/co-log.svg)](https://travis-ci.org/kowainik/co-log)+++Logging library based on [`co-log-core`](../co-log-core) package. Provides+ready-to-go implementation of logging. This README contains _How to_ tutorial on+using this library. This tutorial explains step by step how to integrate+`co-log` into small basic project, specifically how to replace `putStrLn` used+for logging with library provided logging.++All code below can be compiled and run with the following commands:++```shell+$ cabal new-build co-log+$ cabal new-exec readme+```++## Preamble: imports and language extensions++Since this is a literate haskell file, we need to specify all our language+extensions and imports up front.++```haskell+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}++import Colog (Message, WithLog, cmap, fmtMessage, logDebug, logInfo, logTextStdout, logWarning,+              usingLoggerT)+import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.Semigroup ((<>))+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO++```++## Simple IO function example++Consider the following function that reads lines from `stdin` and outputs+different feedback depending on the line size.++```haskell+processLinesBasic :: IO ()+processLinesBasic = do+    line <- TextIO.getLine+    case Text.length line of+        0 -> do+            -- here goes logging+            TextIO.putStrLn ">>>> Empty input"+            processLinesBasic+        n -> do+            TextIO.putStrLn ">>>> Correct input"+            TextIO.putStrLn $ "Line length: " <> Text.pack (show n)+```++This code mixes application logic with logging of the steps. It's convenient to+have logging to observe behavior of the application. But `putStrLn` is very+simple and primitive way to log things.++## Using `co-log` library++In order to use `co-log` library, we need to refactor `processLinesBasic`+function in the following way:++```haskell+processLinesLog :: (WithLog env Message m, MonadIO m) => m ()+processLinesLog = do+    line <- liftIO TextIO.getLine+    case Text.length line of+        0 -> do+            -- here goes logging+            logWarning "Empty input"+            processLinesLog+        n -> do+            logDebug "Correct line"+            logInfo $ "Line length: " <> Text.pack (show n)+```++Let's summarize required changes:++1. Make type more polymorphic: `(WithLog env Message m, MonadIO m) => m ()`+2. Add `liftIO` to all `IO` functions.+3. Replace `putStrLn` with proper `log*` function.++## Running actions++Let's run both functions:++```haskell+main :: IO ()+main = do+    processLinesBasic++    let action = cmap fmtMessage logTextStdout+    usingLoggerT action processLinesLog+```++And here is how output looks like:++![screenshot from 2018-09-17 20-52-01](https://user-images.githubusercontent.com/4276606/45623973-8bafb900-babb-11e8-9e20-4369a5a8e5ff.png)

@@ -1,9 +1,10 @@-cabal-version:       2.0+cabal-version:       2.4 name:                co-log-version:             0.2.0+version:             0.3.0.0 synopsis:            Composable Contravariant Comonadic Logging Library description:-    The default implementation of logging based on [co-log-core](http://hackage.haskell.org/package/co-log-core).+    The default implementation of logging based on+    [co-log-core](http://hackage.haskell.org/package/co-log-core).     .     The ideas behind this package are described in the following blog post:     .@@ -13,46 +14,24 @@ bug-reports:         https://github.com/kowainik/co-log/issues license:             MPL-2.0 license-file:        LICENSE-author:              Kowainik, Alexander Vershilov-maintainer:          xrom.xkov@gmail.com-copyright:           2018 Kowainik-category:            Logging+author:              Dmitrii Kovanikov+maintainer:          Kowainik <xrom.xkov@gmail.com>+copyright:           2018-2019 Kowainik+category:            Logging, Contravariant, Comonad build-type:          Simple+stability:           provisional extra-doc-files:     CHANGELOG.md+                   , README.md tested-with:         GHC == 8.2.2                    , GHC == 8.4.4-                   , GHC == 8.6.2+                   , GHC == 8.6.5  source-repository head   type:                git   location:            https://github.com/kowainik/co-log.git -library-  hs-source-dirs:      src-  exposed-modules:     Colog-                           Colog.Actions-                           Colog.Concurrent-                               Colog.Concurrent.Internal-                           Colog.Contra-                           Colog.Message-                           Colog.Monad-                           Colog.Pure-                           Colog.Rotation--  build-depends:       base >= 4.10 && < 4.13-                     , ansi-terminal ^>= 0.8-                     , bytestring ^>= 0.10.8-                     , co-log-core ^>= 0.1.1-                     , containers >= 0.5.7 && < 0.7-                     , contravariant ^>= 1.5-                     , directory ^>= 1.3.0-                     , filepath ^>= 1.4.1-                     , mtl ^>= 2.2.2-                     , stm >= 2.4 && < 2.6-                     , text ^>= 1.2.3-                     , time >= 1.8 && < 1.10-                     , transformers ^>= 0.5-                     , typerep-map ^>= 0.3.0+common common-options+  build-depends:       base >= 4.10.0.0 && < 4.13    ghc-options:         -Wall                        -Wincomplete-uni-patterns@@ -62,8 +41,9 @@                        -Wredundant-constraints                        -fhide-source-paths                        -freverse-errors-+                       -Wpartial-fields   default-language:    Haskell2010+   default-extensions:  ConstraintKinds                        DeriveGeneric                        GeneralizedNewtypeDeriving@@ -76,34 +56,73 @@                        TypeApplications                        ViewPatterns +common tutorial-options+  import:              common-options+  build-depends:       co-log+                     , co-log-core++  build-tool-depends:  markdown-unlit:markdown-unlit+  ghc-options:         -pgmL markdown-unlit++library+  import:              common-options+  hs-source-dirs:      src+  exposed-modules:     Colog+                           Colog.Actions+                           Colog.Concurrent+                               Colog.Concurrent.Internal+                           Colog.Contra+                           Colog.Message+                           Colog.Monad+                           Colog.Pure+                           Colog.Rotation++  build-depends:       ansi-terminal ^>= 0.9+                     , bytestring ^>= 0.10.8+                     , co-log-core ^>= 0.2.0.0+                     , containers >= 0.5.7 && < 0.7+                     , contravariant ^>= 1.5+                     , directory ^>= 1.3.0+                     , filepath ^>= 1.4.1+                     , mtl ^>= 2.2.2+                     , stm >= 2.4 && < 2.6+                     , text ^>= 1.2.3+                     , chronos ^>= 1.0.4+                     , transformers ^>= 0.5+                     , typerep-map ^>= 0.3.2+ executable play-colog-  hs-source-dirs:      example+  import:              common-options+  hs-source-dirs:      tutorials   main-is:             Main.hs -  build-depends:       base-                     , co-log+  build-depends:       co-log+                     , mtl                      , typerep-map -  ghc-options:         -Wall-                       -Wincomplete-uni-patterns-                       -Wincomplete-record-updates-                       -Wcompat-                       -Widentities-                       -Wredundant-constraints-                       -fhide-source-paths-                       -freverse-errors-                       -threaded+  ghc-options:         -threaded                        -rtsopts                        -with-rtsopts=-N -  default-language:    Haskell2010- executable readme+  import:              tutorial-options   main-is:             README.lhs-  build-depends:       base-                     , co-log-                     , text+  build-depends:       text -  build-tool-depends:  markdown-unlit:markdown-unlit-  ghc-options:         -Wall -pgmL markdown-unlit-  default-language:    Haskell2010+executable tutorial-intro+  import:              tutorial-options+  main-is:             tutorials/1-intro/Intro.lhs++executable tutorial-custom+  import:              tutorial-options+  main-is:             tutorials/2-custom/Custom.lhs+  build-depends:       mtl++test-suite test-co-log+  import:              common-options+  build-depends:       co-log+                     , co-log-core+                     , hedgehog ^>= 0.6+  hs-source-dirs:      test+  main-is:             Property.hs+  type:                exitcode-stdio-1.0

@@ -1,122 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms   #-}-{-# LANGUAGE TypeApplications  #-}--module Main where--import Prelude hiding (log)--import Control.Concurrent (threadDelay)-import Control.Exception (Exception)-import Control.Monad.IO.Class (MonadIO (..))-import Data.Semigroup ((<>))--import Colog (pattern D, LogAction, Message (..), PureLogger, WithLog, cmap, cmapM, defaultFieldMap,-              fmtMessage, fmtRichMessageDefault, log, logException, logInfo, logMessagePure, logMsg,-              logMsgs, logPrint, logStringStdout, logTextStderr, logTextStdout, logWarning,-              runPureLog, upgradeMessageAction, usingLoggerT, withLog, withLogTextFile, (*<), (>$),-              (>$<), (>*), (>*<), (>|<))--import qualified Data.TypeRepMap as TM--example :: WithLog env Message m => m ()-example = do-    log D "First message..."-    logInfo "Second message..."--app :: (WithLog env Message m, MonadIO m) => m ()-app = do-    logWarning "Starting application..."-    liftIO $ threadDelay $ 10^(6 :: Int)-    withLog (cmap addApp) $ do-        example-        exceptionL-        logInfo "Application finished..."-  where-    addApp :: Message -> Message-    addApp msg = msg { messageText = "app: " <> messageText msg }---foo :: (WithLog env String m, WithLog env Int m) => m ()-foo = do-    logMsg ("String message..." :: String)-    logMsg @Int 42--data ExampleException = ExampleException-    deriving (Show, Exception)--exceptionL :: (WithLog env Message m) => m ()-exceptionL = logException ExampleException--------------------------------------------------------------------------------- Section with contravariant combinators example-------------------------------------------------------------------------------data Engine = Pistons Int | Rocket--engineToEither :: Engine -> Either Int ()-engineToEither e = case e of-    Pistons i -> Left i-    Rocket    -> Right ()--data Car = Car-    { carMake   :: String-    , carModel  :: String-    , carEngine :: Engine-    }--carToTuple :: Car -> (String, (String, Engine))-carToTuple (Car make model engine) = (make, (model, engine))--stringL :: LogAction IO String-stringL = logStringStdout---- Returns log action that logs given string ignoring its input.-constL :: String -> LogAction IO a-constL s = s >$ stringL--intL :: LogAction IO Int-intL = logPrint---- log actions that logs single car module-carL :: LogAction IO Car-carL = carToTuple-    >$< (constL "Logging make..." *< stringL >* constL "Finished logging make...")-    >*< (constL "Logging model.." *< stringL >* constL "Finished logging model...")-    >*< ( engineToEither-      >$< constL "Logging pistons..." *< intL-      >|< constL "Logging rocket..."-        )--------------------------------------------------------------------------------- main runner-------------------------------------------------------------------------------main :: IO ()-main = withLogTextFile "co-log/example/example.log" $ \logTextFile -> do-    let runApp :: LogAction IO Message -> IO ()-        runApp action = usingLoggerT action app--    let textAction = logTextStdout <> logTextStderr <> logTextFile--    let simpleMessageAction = cmap  fmtMessage            textAction-    let richMessageAction   = cmapM fmtRichMessageDefault textAction--    let fullMessageAction = upgradeMessageAction defaultFieldMap richMessageAction-    let semiMessageAction = upgradeMessageAction-                                (TM.delete @"threadId" defaultFieldMap)-                                richMessageAction--    runApp simpleMessageAction-    runApp fullMessageAction-    runApp semiMessageAction--    usingLoggerT carL $ logMsg $ Car "Toyota" "Corolla" (Pistons 4)--    let pureAction :: PureLogger Message ()-        pureAction = usingLoggerT logMessagePure example-    let ((), msgs) = runPureLog pureAction-    usingLoggerT simpleMessageAction $ logMsgs msgs

@@ -1,3 +1,12 @@+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++This package contains @mtl@ implementation of composable, contravariant and+comonadic logging based on @co-log-core@.+-}+ module Colog        ( module Colog.Actions        , module Colog.Core

@@ -1,6 +1,13 @@+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Logging actions for various text types.+-}+ module Colog.Actions-       (-         -- * 'ByteString' actions+       ( -- * 'ByteString' actions          logByteStringStdout        , logByteStringStderr        , logByteStringHandle@@ -11,12 +18,20 @@        , logTextStderr        , logTextHandle        , withLogTextFile++         -- * 'Message' actions+         -- $msg+       , simpleMessageAction+       , richMessageAction        ) where  import Control.Monad.IO.Class (MonadIO (..))+import Data.Text.Encoding (encodeUtf8) import System.IO (Handle, IOMode (AppendMode), stderr, withFile) -import Colog.Core.Action (LogAction (..))+import Colog.Core.Action (LogAction (..), cmapM, (>$<))+import Colog.Message (Message, defaultFieldMap, fmtMessage, fmtRichMessageDefault,+                      upgradeMessageAction)  import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8@@ -27,39 +42,81 @@ -- ByteString ---------------------------------------------------------------------------- -{- | Action that prints 'ByteString' to stdout. -}+{- | Action that prints 'BS.ByteString' to stdout. -} logByteStringStdout :: MonadIO m => LogAction m BS.ByteString logByteStringStdout = LogAction $ liftIO . BS8.putStrLn+{-# INLINE logByteStringStdout #-}+{-# SPECIALIZE logByteStringStdout :: LogAction IO BS.ByteString #-} -{- | Action that prints 'ByteString' to stderr. -}+{- | Action that prints 'BS.ByteString' to stderr. -} logByteStringStderr :: MonadIO m => LogAction m BS.ByteString logByteStringStderr = logByteStringHandle stderr+{-# INLINE logByteStringStderr #-}+{-# SPECIALIZE logByteStringStderr :: LogAction IO BS.ByteString #-} -{- | Action that prints 'ByteString' to 'Handle'. -}+{- | Action that prints 'BS.ByteString' to 'Handle'. -} logByteStringHandle :: MonadIO m => Handle -> LogAction m BS.ByteString logByteStringHandle handle = LogAction $ liftIO . BS8.hPutStrLn handle+{-# INLINE logByteStringHandle #-}+{-# SPECIALIZE logByteStringHandle :: Handle -> LogAction IO BS.ByteString #-} -{- | Action that prints 'ByteString' to file. See 'withLogStringFile' for details. -}+{- | Action that prints 'BS.ByteString' to file. See+'Colog.Core.Action.withLogStringFile' for details.+-} withLogByteStringFile :: MonadIO m => FilePath -> (LogAction m BS.ByteString -> IO r) -> IO r withLogByteStringFile path action = withFile path AppendMode $ action . logByteStringHandle+{-# INLINE withLogByteStringFile #-}+{-# SPECIALIZE withLogByteStringFile :: FilePath -> (LogAction IO BS.ByteString -> IO r) -> IO r #-}  ---------------------------------------------------------------------------- -- Text ---------------------------------------------------------------------------- -{- | Action that prints 'Text' to stdout. -}+{- | Action that prints 'T.Text' to stdout. -} logTextStdout :: MonadIO m => LogAction m T.Text logTextStdout = LogAction $ liftIO . TIO.putStrLn+{-# INLINE logTextStdout #-}+{-# SPECIALIZE logTextStdout :: LogAction IO T.Text #-} -{- | Action that prints 'Text' to stderr. -}+{- | Action that prints 'T.Text' to stderr. -} logTextStderr :: MonadIO m => LogAction m T.Text logTextStderr = logTextHandle stderr+{-# INLINE logTextStderr #-}+{-# SPECIALIZE logTextStderr :: LogAction IO T.Text #-} -{- | Action that prints 'Text' to 'Handle'. -}+{- | Action that prints 'T.Text' to 'Handle'. -} logTextHandle :: MonadIO m => Handle -> LogAction m T.Text logTextHandle handle = LogAction $ liftIO . TIO.hPutStrLn handle+{-# INLINE logTextHandle #-}+{-# SPECIALIZE logTextHandle :: Handle -> LogAction IO T.Text #-} -{- | Action that prints 'Text' to file. See 'withLogStringFile' for details. -}+{- | Action that prints 'T.Text' to file. See+'Colog.Core.Action.withLogStringFile' for details.+-} withLogTextFile :: MonadIO m => FilePath -> (LogAction m T.Text -> IO r) -> IO r withLogTextFile path action = withFile path AppendMode $ action . logTextHandle+{-# INLINE withLogTextFile #-}+{-# SPECIALIZE withLogTextFile :: FilePath -> (LogAction IO T.Text -> IO r) -> IO r #-} +----------------------------------------------------------------------------+-- Message+----------------------------------------------------------------------------++{- $msg+Default logging actions to make the usage with 'Message's easier.+-}++{- | Action that prints 'Message' to 'stdout'. -}+simpleMessageAction :: MonadIO m => LogAction m Message+simpleMessageAction = encodeUtf8 . fmtMessage >$< logByteStringStdout+{-# INLINE simpleMessageAction #-}+{-# SPECIALIZE simpleMessageAction :: LogAction IO Message#-}++{- | Action that constructs 'Colog.Message.RichMessage' and prints formatted+'Message' for it to 'stdout'.+-}+richMessageAction :: MonadIO m => LogAction m Message+richMessageAction = upgradeMessageAction defaultFieldMap $+    cmapM (fmap encodeUtf8 . fmtRichMessageDefault) logByteStringStdout+{-# INLINE richMessageAction #-}+{-# SPECIALIZE richMessageAction :: LogAction IO Message #-}

@@ -1,32 +1,39 @@--- |--- For the speed reasons you may want to dump logs asynchronously.--- This is especially useful when application threads are CPU--- bound while logs emitting is I/O bound. This approach--- allows to mitigate bottlenecks from the I/O.------ When writing an application user should be aware of the tradeoffs--- that concurrent log system can provide, in this module we explain--- potential tradeoffs and describe if certain building blocks are--- affected or not.------   1. Unbounded memory usage - if there is no backpressure mechanism---   the user threads, they may generate more logs that can be---   written in the same amount of time. In those cases messages will---   be accumulated in memory. That will lead to extended GC times and---   application may be killed by the operating systems mechanisms.------   2. Persistence requirement - sometimes application may want to---   ensure that logs were written before it can continue. This is not---   a case with concurrent log systems in general, and some logs may---   be lost when application exits before dumping all logs.------   3. Non-precise logging - sometimes it may happen that there can be---   logs reordering (in case if thread was moved to another capability).------ In case if your application is a subject of those problems you may--- consider not using concurrent logging system in other cases concurrent--- logger may be a good default for you.---+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++__NOTE:__ Many thanks to Alexander Vershilov for the implementation.++For the speed reasons you may want to dump logs asynchronously.+This is especially useful when application threads are CPU+bound while logs emitting is I/O bound. This approach+allows to mitigate bottlenecks from the I/O.++When writing an application user should be aware of the tradeoffs+that concurrent log system can provide, in this module we explain+potential tradeoffs and describe if certain building blocks are+affected or not.++  1. Unbounded memory usage - if there is no backpressure mechanism+  the user threads, they may generate more logs that can be+  written in the same amount of time. In those cases messages will+  be accumulated in memory. That will lead to extended GC times and+  application may be killed by the operating systems mechanisms.++  2. Persistence requirement - sometimes application may want to+  ensure that logs were written before it can continue. This is not+  a case with concurrent log systems in general, and some logs may+  be lost when application exits before dumping all logs.++  3. Non-precise logging - sometimes it may happen that there can be+  logs reordering (in case if thread was moved to another capability).++In case if your application is a subject of those problems you may+consider not using concurrent logging system in other cases concurrent+logger may be a good default for you.+-}+ module Colog.Concurrent        ( -- $general          -- * Simple API.

@@ -1,7 +1,14 @@ {-# LANGUAGE CPP #-} -{- | This is internal module, use it on your own risk. The implementation here-may be changed without a version bump.+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++__NOTE:__ Many thanks to Alexander Vershilov for the implementation.++This is internal module, use it on your own risk. The implementation here may be+changed without a version bump. -}  module Colog.Concurrent.Internal@@ -24,9 +31,9 @@ -- | Wrapper for the background thread that may -- receive messages to process. data BackgroundWorker msg = BackgroundWorker-  { backgroundWorkerThreadId :: !ThreadId-    -- ^ Background 'ThreadId'.-  , backgroundWorkerWrite    :: msg -> STM ()-    -- ^ Method for communication with the thread.-  , backgroundWorkerIsAlive  :: TVar Bool-  }+    { backgroundWorkerThreadId :: !ThreadId+      -- ^ Background 'ThreadId'.+    , backgroundWorkerWrite    :: msg -> STM ()+      -- ^ Method for communication with the thread.+    , backgroundWorkerIsAlive  :: TVar Bool+    }

@@ -1,7 +1,13 @@-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{- | This module contains 'LogAction' instances of @contravariant@ classes.+{-# LANGUAGE CPP #-}++{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++This module contains 'LogAction' orphan instances of @contravariant@ classes. -}  module Colog.Contra@@ -14,18 +20,26 @@ import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))  import Colog.Core.Action (LogAction)+ import qualified Colog.Core.Action as LA + #if !MIN_VERSION_base(4,12,0) instance Contravariant (LogAction m) where     contramap = LA.cmap-    (>$)      = (LA.>$)+    {-# INLINE contramap #-}+    (>$) = (LA.>$)+    {-# INLINE (>$) #-} #endif  instance (Applicative m) => Divisible (LogAction m) where     divide  = LA.divide+    {-# INLINE divide #-}     conquer = LA.conquer+    {-# INLINE conquer #-}  instance (Applicative m) => Decidable (LogAction m) where     lose   = LA.lose+    {-# INLINE lose #-}     choose = LA.choose+    {-# INLINE choose #-}

@@ -3,33 +3,46 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels      #-} {-# LANGUAGE TypeFamilies          #-} -{- | 'Message' with 'Severity', and logging functions for them.+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++This module contains logging messages data types along with the formatting and+logging actions for them. -}  module Colog.Message        ( -- * Basic message type-         Message (..)-       , unMessageField+         Msg (..)+       , Message        , log        , logDebug        , logInfo        , logWarning        , logError        , logException++         -- * Formatting functions        , fmtMessage+       , showSeverity+       , showSourceLoc           -- * Externally extensible message type+         -- ** Field of the dependent map        , FieldType        , MessageField (..)+       , unMessageField+       , extractField+         -- ** Dependent map that allows to extend logging message        , FieldMap        , defaultFieldMap -       , RichMessage+       , RichMessage (..)        , fmtRichMessageDefault        , upgradeMessageAction        ) where@@ -42,8 +55,7 @@ import Data.Kind (Type) import Data.Semigroup ((<>)) import Data.Text (Text)-import Data.Time.Clock (UTCTime, getCurrentTime)-import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Text.Lazy (toStrict) import Data.TypeRepMap (TypeRepMap) import GHC.Exts (IsList (..)) import GHC.OverloadedLabels (IsLabel (..))@@ -55,38 +67,52 @@ import Colog.Core (LogAction, Severity (..), cmap) import Colog.Monad (WithLog, logMsg) +import qualified Chronos as C import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TB import qualified Data.TypeRepMap as TM  ---------------------------------------------------------------------------- -- Plain message ---------------------------------------------------------------------------- --- | Consist of the message 'Severity' level and the message itself.-data Message = Message-    { messageSeverity :: !Severity-    , messageStack    :: !CallStack-    , messageText     :: !Text+{- | General logging message data type. Contains the following fields:++1. Polymorhic severity. This can be anything you want if you need more+flexibility.+2. Function 'CallStack'. It provides useful information about source code+locations where each particular function was called.+3. Custom text for logging.+-}+data Msg sev = Msg+    { msgSeverity :: !sev+    , msgStack    :: !CallStack+    , msgText     :: !Text     } --- | Logs the message with given 'Severity'.-log :: WithLog env Message m => Severity -> Text -> m ()-log messageSeverity messageText =-    withFrozenCallStack (logMsg Message{ messageStack = callStack, .. })+{- | 'Msg' parametrized by the 'Severity' type. Most formatting functions in+this module work with 'Severity' from @co-log-core@.+-}+type Message = Msg Severity --- | Logs the message with 'Debug' severity.+-- | Logs the message with given severity @sev@.+log :: WithLog env (Msg sev) m => sev -> Text -> m ()+log msgSeverity msgText =+    withFrozenCallStack (logMsg Msg{ msgStack = callStack, .. })++-- | Logs the message with the 'Debug' severity. logDebug :: WithLog env Message m => Text -> m () logDebug = withFrozenCallStack (log Debug) --- | Logs the message with 'Info' severity.+-- | Logs the message with the 'Info' severity. logInfo :: WithLog env Message m => Text -> m () logInfo = withFrozenCallStack (log Info) --- | Logs the message with 'Warning' severity.+-- | Logs the message with the 'Warning' severity. logWarning :: WithLog env Message m => Text -> m () logWarning = withFrozenCallStack (log Warning) --- | Logs the message with 'Error' severity.+-- | Logs the message with the 'Error' severity. logError :: WithLog env Message m => Text -> m () logError = withFrozenCallStack (log Error) @@ -94,14 +120,29 @@ logException :: forall e m env . (WithLog env Message m, Exception e) => e -> m () logException = withFrozenCallStack (logError . T.pack . displayException) --- | Prettifies 'Message' type.+{- | Formats the 'Message' type in according to the following format:++@+[Severity] [SourceLocation] \<Text message\>+@++__Examples:__++@+[Warning] [Main.app#39] Starting application...+[Debug]   [Main.example#34] app: First message...+@++See 'fmtRichMessageDefault' for richer format.+-} fmtMessage :: Message -> Text-fmtMessage Message{..} =-    showSeverity messageSeverity- <> showSourceLoc messageStack- <> messageText+fmtMessage Msg{..} =+    showSeverity msgSeverity+    <> showSourceLoc msgStack+    <> msgText --- | Prints severity in different colours+{- | Formats severity in different colours with alignment.+-} showSeverity :: Severity -> Text showSeverity = \case     Debug   -> color Green  "[Debug]   "@@ -110,13 +151,20 @@     Error   -> color Red    "[Error]   "  where     color :: Color -> Text -> Text-    color c txt = T.pack (setSGRCode [SetColor Foreground Vivid c])+    color c txt =+        T.pack (setSGRCode [SetColor Foreground Vivid c])         <> txt         <> T.pack (setSGRCode [Reset])  square :: Text -> Text square t = "[" <> t <> "] " +{- | Show source code locations in the following format:++@+[Main.example#35]+@+-} showSourceLoc :: CallStack -> Text showSourceLoc cs = square showCallStack   where@@ -139,7 +187,7 @@ -} type family FieldType (fieldName :: Symbol) :: Type type instance FieldType "threadId" = ThreadId-type instance FieldType "utcTime"  = UTCTime+type instance FieldType "posixTime"  = C.Time  {- | @newtype@ wrapper. Stores monadic ability to extract value of 'FieldType'. @@ -167,8 +215,10 @@ newtype MessageField (m :: Type -> Type) (fieldName :: Symbol) where     MessageField :: forall fieldName m . m (FieldType fieldName) -> MessageField m fieldName +-- | Extracts field from the 'MessageField' constructor. unMessageField :: forall fieldName m . MessageField m fieldName -> m (FieldType fieldName) unMessageField (MessageField f) = f+{-# INLINE unMessageField #-}  instance (KnownSymbol fieldName, a ~ m (FieldType fieldName))       => IsLabel fieldName (a -> TM.WrapTypeable (MessageField m)) where@@ -179,11 +229,13 @@ #endif     {-# INLINE fromLabel #-} +-- | Helper function to deal with 'MessageField' when looking it up in the 'FieldMap'. extractField     :: Applicative m     => Maybe (MessageField m fieldName)     -> m (Maybe (FieldType fieldName)) extractField = traverse unMessageField+{-# INLINE extractField #-}  -- same as: -- extractField = \case@@ -196,17 +248,17 @@ type FieldMap (m :: Type -> Type) = TypeRepMap (MessageField m)  {- | Default message map that contains actions to extract 'ThreadId' and-'UTCTime'. Basically, the following mapping:+'C.Time'. Basically, the following mapping:  @-"threadId" -> myThreadId-"utcTime"  -> getCurrentTime+"threadId"  -> 'myThreadId'+"posixTime" -> 'C.now' @ -} defaultFieldMap :: MonadIO m => FieldMap m defaultFieldMap = fromList-    [ #threadId (liftIO myThreadId)-    , #utcTime  (liftIO getCurrentTime)+    [ #threadId  (liftIO myThreadId)+    , #posixTime (liftIO C.now)     ]  -- | Contains additional data to 'Message' to display more verbose information.@@ -218,28 +270,41 @@ {- | Formats 'RichMessage' in the following way:  @-[Severity] [Time] [SourceLocation] [ThreadId] <Text message>+[Severity] [Time] [SourceLocation] [ThreadId] \<Text message\> @++__Examples:__++@+[Debug]   [03 05 2019 05:23:19.058] [Main.example#34] [ThreadId 11] app: First message...+[Info]    [03 05 2019 05:23:19.059] [Main.example#35] [ThreadId 11] app: Second message...+@++See 'fmtMessage' if you don't need both time and thread id. -} fmtRichMessageDefault :: MonadIO m => RichMessage m -> m Text fmtRichMessageDefault RichMessage{..} = do-    maybeThreadId <- extractField $ TM.lookup @"threadId" richMessageMap-    maybeUtcTime  <- extractField $ TM.lookup @"utcTime"  richMessageMap-    pure $ formatRichMessage maybeThreadId maybeUtcTime richMessageMsg+    maybeThreadId  <- extractField $ TM.lookup @"threadId"  richMessageMap+    maybePosixTime <- extractField $ TM.lookup @"posixTime" richMessageMap+    pure $ formatRichMessage maybeThreadId maybePosixTime richMessageMsg   where-    formatRichMessage :: Maybe ThreadId -> Maybe UTCTime -> Message -> Text-    formatRichMessage (maybe "" showThreadId -> thread) (maybe "" showTime -> time) Message{..} =-        showSeverity messageSeverity+    formatRichMessage :: Maybe ThreadId -> Maybe C.Time -> Message -> Text+    formatRichMessage (maybe "" showThreadId -> thread) (maybe "" showTime -> time) Msg{..} =+        showSeverity msgSeverity      <> time-     <> showSourceLoc messageStack+     <> showSourceLoc msgStack      <> thread-     <> messageText+     <> msgText -    showTime :: UTCTime -> Text-    showTime t = square $ T.pack $-          formatTime defaultTimeLocale "%H:%M:%S." t-       ++ take 3 (formatTime defaultTimeLocale "%q" t)-       ++ formatTime defaultTimeLocale " %e %b %Y %Z" t+    showTime :: C.Time -> Text+    showTime t =+        square+        $ toStrict+        $ TB.toLazyText+        $ C.builder_DmyHMS timePrecision datetimeFormat (C.timeToDatetime t)+      where+        timePrecision = C.SubsecondPrecisionFixed 3+        datetimeFormat = C.DatetimeFormat (Just '-') (Just ' ') (Just ':')      showThreadId :: ThreadId -> Text     showThreadId = square . T.pack . show

@@ -1,5 +1,13 @@ {-# LANGUAGE InstanceSigs #-} +{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Core of the @mtl@ implementation.+-}+ module Colog.Monad        ( LoggerT (..)        , WithLog@@ -29,6 +37,7 @@ instance MonadTrans (LoggerT msg) where     lift :: Monad m => m a -> LoggerT msg m a     lift = LoggerT . lift+    {-# INLINE lift #-}  type WithLog env msg m = (MonadReader env m, HasLog env msg m, HasCallStack) @@ -48,10 +57,12 @@ logMsg msg = do     LogAction log <- asks getLogAction     log msg+{-# INLINE logMsg #-}  -- | Logs multiple messages. logMsgs :: forall msg env f m . (Foldable f, WithLog env msg m) => f msg -> m () logMsgs = traverse_ logMsg+{-# INLINE logMsgs #-}  {- | Performs given monadic logging action by applying function to every logging record. @@ -64,9 +75,11 @@ -} withLog :: WithLog env msg m => (LogAction m msg -> LogAction m msg) -> m a -> m a withLog = local . overLogAction+{-# INLINE withLog #-}  liftLogAction :: (Monad m, MonadTrans t) => LogAction m msg -> LogAction (t m) msg liftLogAction (LogAction action) = LogAction (lift . action)+{-# INLINE liftLogAction #-}  {- | Runner for 'LoggerT' monad. Let's consider one simple example of monadic action you have:@@ -95,4 +108,4 @@ @ -} usingLoggerT :: Monad m => LogAction m msg -> LoggerT msg m a -> m a-usingLoggerT action =  flip runReaderT (liftLogAction action) . runLoggerT+usingLoggerT action = flip runReaderT (liftLogAction action) . runLoggerT

@@ -1,4 +1,9 @@-{- | Pure implementation of logging action.+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>++Pure implementation of logging action. -}  module Colog.Pure@@ -38,7 +43,9 @@ -- | Returns result value of 'PureLogger' and list of logged messages. runPureLog :: PureLogger msg a -> (a, [msg]) runPureLog = runIdentity . runPureLogT+{-# INLINE runPureLog #-}  -- | 'LogAction' that prints @msg@ by appending it to the end of the sequence. logMessagePure :: Monad m => LogAction (PureLoggerT msg m) msg logMessagePure = LogAction $ \msg -> modify' (|> msg)+{-# INLINE logMessagePure #-}

@@ -1,9 +1,15 @@--- |--- This functionality is not to be considered stable--- or ready for production use. While we enourage you--- to try it out and report bugs, we cannot assure you--- that everything will work as advertised :)+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MPL-2.0+Maintainer: Kowainik <xrom.xkov@gmail.com>+Stability:  experimental +__NOTE:__ This functionality is not to be considered stable+or ready for production use. While we enourage you+to try it out and report bugs, we cannot assure you+that everything will work as advertised :)+-}+ module Colog.Rotation        ( Limit(..)        , withLogRotation@@ -26,6 +32,11 @@ import qualified System.FilePath.Posix as POS  +{- | Limit for the logger rotation. Used for two purposes:++1. Limit the number of kept files.+2. Limit the size of the files.+-} data Limit = LimitTo Natural | Unlimited deriving (Eq, Ord)  {- | Logger rotation action. Takes name of the logging file @file.foo@. Always

@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell  #-}++module Main where++import Data.Semigroup ((<>))+import Hedgehog (MonadGen, Property, checkSequential, discover, forAll, property, (===))+import System.Exit (exitFailure, exitSuccess)+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)++import Colog.Core (LogAction)+import Colog.Monad (logMsg, usingLoggerT)+import Colog.Pure (PureLogger, logMessagePure, runPureLog)++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++data LogAST+    = LogMsg+    | AND LogAST LogAST deriving Show++listLogMessages :: LogAST -> String -> [String]+listLogMessages LogMsg msg    = [msg]+listLogMessages (AND a b) msg = listLogMessages a msg ++ listLogMessages b msg++processAST :: LogAction (PureLogger String) String -> String -> [String]+processAST action msg = snd $ runPureLog $ usingLoggerT action $ logMsg msg++toLoggerAction :: LogAST -> LogAction (PureLogger String) String+toLoggerAction LogMsg    = logMessagePure+toLoggerAction (AND a b) = toLoggerAction a <> toLoggerAction b++genAST :: MonadGen m => m LogAST+genAST = Gen.recursive+    Gen.choice+    [ Gen.constant LogMsg ]+    [ Gen.subterm2 genAST genAST AND ]++prop_test_validate :: Property+prop_test_validate = property $ do+    msg <- forAll $ Gen.string (Range.constant 1 100) Gen.unicode+    ast <- forAll genAST+    processAST (toLoggerAction ast) msg === listLogMessages ast msg++prop_test_assoc :: Property+prop_test_assoc = property $ do+    msg <- forAll $ Gen.string (Range.constant 1 100) Gen.unicode+    x <- forAll genAST+    y <- forAll genAST+    z <- forAll genAST+    let ax = toLoggerAction x+    let ay = toLoggerAction y+    let az = toLoggerAction z+    processAST ((ax <> ay) <> az) msg === processAST (ax <> (ay <> az)) msg++tests :: IO Bool+tests = checkSequential $$(discover)++main :: IO ()+main = do+    hSetBuffering stdout LineBuffering+    hSetBuffering stderr LineBuffering+    tests >>= \p -> if p then exitSuccess else exitFailure

@@ -0,0 +1,122 @@+# Intro: Using `LogAction`++This tutorial is an introduction to `co-log`. It contains basic examples of+using core data types and functions.++You can run this tutorial by calling the following command:++```shell+cabal new-run tutorial-intro+```++## Preamble: imports and language extensions++Since this is a literate haskell file, we need to specify all our language+extensions and imports up front.++```haskell+import Colog.Core (LogAction (..), (<&), logStringStdout)+```++## Core data type++`co-log` is based on the following data type:++```idris+newtype LogAction m msg = LogAction+    { unLogAction :: msg -> m ()+    }+```++Logging action is a function from some message of user-defined type `msg` that+performs all logic inside some monad `m`. In the `co-log` library **logger** is represented as a+value. With such approach, you can modify the way you do logging by simply performing some+transformations with the value you have.++Let's first look at a very basic example of simply using `putStrLn` for logging:++```haskell+example0 :: IO ()+example0 = do+    putStrLn "Example 0: First message"+    putStrLn "Example 0: Second message"+```++Using `putStrLn` for logging is a very simple and basic approach for logging.+When your application becomes bigger and more complex, you might want to bring+some logging library into it. For example, you might want to do something from+the following list:++1. Specify messages with the given `Severity` so you can control the verbosity+   of the output.+2. Automatically print timestamps, thread ids, source code line of the logging+   with each message.+3. You would like to submit some statistics to some web-server with each logging+   message so later you can have analytics provided by external parties.++Now let's look at how you can use `LogAction` instead of `putStrLn` to achieve the+same goal. With `co-log` you need to have a value of type `LogAction` that defines+how you are going to do logging. So you configure your logging settings separately and+then pass and use this `LogAction` value. See the following example for more+details:++```haskell+example1 :: LogAction IO String -> IO ()+example1 logger = do+    unLogAction logger "Example 1: First message"+    unLogAction logger "Example 1: Second message"+```++> **NOTE:** this function currently does exactly the same thing as in `example0`. However,+> given `LogAction` can do many different interesting things which you can+> configure later in one place and automatically get proper behavior for your+> whole application instead of changing the code of every function.++If you want to do logging with `co-log`, then one of the options (and the simplest one)+is to pass `LogAction` explicitly as an argument to your+function. In the example above, we are using `LogAction` that takes `String`s as messages+and performs logging inside `IO` monad.++For convenience, library defines useful operator `<&` that makes code more+concise and simpler:++```haskell+example2 :: LogAction IO String -> IO ()+example2 logger = do+    logger <& "Example 2: First message"+    logger <& "Example 2: Second message"+```++In order to do some logging, we need to pass some `logger` to our functions.+Here we are going to use the following `LogAction`:++```idris+logStringStdout :: LogAction IO String+```++This action uses `putStrLn` underhood and just prints given string to `stdout`.+In this particular case using `LogAction` from `co-log` might seem redundant,+however, now it's much easier to replace simple `putStrLn` with something more+complex and useful.++Putting all together, we can now perform our++```haskell+main :: IO ()+main = do+    let logger = logStringStdout+    example0+    example1 logger+    example2 logger+```++And the output is exactly what you expect:++```+Example 0: First message+Example 0: Second message+Example 1: First message+Example 1: Second message+Example 2: First message+Example 2: Second message+```

@@ -0,0 +1,135 @@+# Using custom monad that stores `LogAction` inside its environment++This tutorial covers more advanced topic of using `co-log` library with custom+application monad.++You can run this tutorial by calling the following command:++```shell+cabal new-run tutorial-custom+```++## Preamble: imports and language extensions++Since this is a literate haskell file, we need to specify all our language+extensions and imports up front.++```haskell+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms       #-}++import Prelude hiding (log)++import Colog (pattern D, HasLog (..), pattern I, LogAction, Message, WithLog, log,+              richMessageAction)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (MonadReader, ReaderT (..))+```++## Application environment++If you have complex Haskell application, then most likely you also have+non-trivial settings that configure your application environment. The+environment may store various parameters important for the work of your application.+Interestingly, we can store `LogAction` inside the same environment to use it+automatically for our logging functions.++The environment for your application can look like this:++```haskell+data Env m = Env+    { envServerPort :: !Int+    , envLogAction  :: !(LogAction m Message)+    }+```++Several notes about this data type:++1. It stores different parameters, like server port.+2. It stores `LogAction` that can log `Message` data type from `co-log` in the+   `m` monad.+3. `Env` is parameterized by type variable `m` which is going to be application+   monad.++Next step is to define an instance of the `HasLog` typeclass for the `Env` data+type. This instance will tell how to get and update `LogAction` stored inside+the environment.++```haskell+instance HasLog (Env m) Message m where+    getLogAction :: Env m -> LogAction m Message+    getLogAction = envLogAction+    {-# INLINE getLogAction #-}++    setLogAction :: LogAction m Message -> Env m -> Env m+    setLogAction newLogAction env = env { envLogAction = newLogAction }+    {-# INLINE setLogAction #-}+```++That's it! `co-log` requires very little boilerplate.++## Application monad++Now let's define our application monad.++```haskell+newtype App a = App+    { unApp :: ReaderT (Env App) IO a+    } deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Env App))+```++This monad stores `Env` parameterized by the monad itself in it's context.+Nothing special required here to tell the monad how to use logger.++## Example++`co-log` relies on tagless final technique for writing function. So you define+your monadic actions with the `WithLog` constraint that allows you to perform+logging:++```haskell+example :: WithLog env Message m => m ()+example = do+    log D "First message..."+    log I "Second message..."+```++Constraint `WithLog` has three type parameters: application environment, type of+the message and monad. Function `log` takes two parameters: logger severity and+message text.++## Running example++Now we are ready to execute this action.++First, let's create example environment:++```haskell+simpleEnv :: Env App+simpleEnv = Env+    { envServerPort = 8081+    , envLogAction  = richMessageAction+    }+```++Then we need to define a function that performs actions of type `App`:++```haskell+runApp :: Env App -> App a -> IO a+runApp env app = runReaderT (unApp app) env+```++Putting all together, we can specialize `WithLog` constraint to our `App` monad+and run our example.++```haskell+main :: IO ()+main = runApp simpleEnv example+```++And the output will look like this:++![Output example](https://user-images.githubusercontent.com/4276606/57193360-c001b800-6f6c-11e9-9f0a-6027eda3aa37.png)

@@ -0,0 +1,188 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeSynonymInstances       #-}++module Main where++import Prelude hiding (log)++import Control.Concurrent (threadDelay)+import Control.Exception (Exception)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader, ReaderT (..))+import Data.Semigroup ((<>))++import Colog (pattern D, HasLog (..), LogAction, Message, Msg (..), PureLogger, WithLog, cmap,+              cmapM, defaultFieldMap, fmtMessage, fmtRichMessageDefault, liftLogIO, log,+              logException, logInfo, logMessagePure, logMsg, logMsgs, logPrint, logStringStdout,+              logTextStderr, logTextStdout, logWarning, runPureLog, upgradeMessageAction,+              usingLoggerT, withLog, withLogTextFile, (*<), (<&), (>$), (>$<), (>*), (>*<), (>|<))++import qualified Data.TypeRepMap as TM++example :: WithLog env Message m => m ()+example = do+    log D "First message..."+    logInfo "Second message..."++app :: (WithLog env Message m, MonadIO m) => m ()+app = do+    logWarning "Starting application..."+    liftIO $ threadDelay $ 10^(6 :: Int)+    withLog (cmap addApp) $ do+        example+        exceptionL+        logInfo "Application finished..."+  where+    addApp :: Message -> Message+    addApp msg = msg { msgText = "app: " <> msgText msg }++++data ExampleException = ExampleException+    deriving (Show, Exception)++exceptionL :: (WithLog env Message m) => m ()+exceptionL = logException ExampleException++----------------------------------------------------------------------------+-- Message passing with pipes: &> and <&++-- Remember:+-- (<&) :: LogAction m msg -> msg -> m ()+----------------------------------------------------------------------------++data Collatz = Collatz {even :: Bool, n :: Int, iteration :: Int}++collatz :: LogAction IO String -> Collatz -> IO ()+collatz logger (Collatz False 1 iter) =+    logger <& ("Found 1 after " ++ show iter ++ " iterations")+collatz logger (Collatz even' x iter) = do+    logger <& (show x ++ " on iteration " ++ show iter)+    let newN = if even' then x `div` 2 else 3 * x + 1+    collatz logger $ Collatz (newN `mod` 2 == 0) newN (iter + 1)++----------------------------------------------------------------------------+-- Section with contravariant combinators example+----------------------------------------------------------------------------++data Engine = Pistons Int | Rocket++engineToEither :: Engine -> Either Int ()+engineToEither e = case e of+    Pistons i -> Left i+    Rocket    -> Right ()++data Car = Car+    { carMake   :: String+    , carModel  :: String+    , carEngine :: Engine+    }++carToTuple :: Car -> (String, (String, Engine))+carToTuple (Car make model engine) = (make, (model, engine))++stringL :: LogAction IO String+stringL = logStringStdout++-- Returns log action that logs given string ignoring its input.+constL :: String -> LogAction IO a+constL s = s >$ stringL++intL :: LogAction IO Int+intL = logPrint++-- log actions that logs single car module+carL :: LogAction IO Car+carL = carToTuple+    >$< (constL "Logging make..." *< stringL >* constL "Finished logging make...")+    >*< (constL "Logging model.." *< stringL >* constL "Finished logging model...")+    >*< ( engineToEither+      >$< constL "Logging pistons..." *< intL+      >|< constL "Logging rocket..."+        )++----------------------------------------------------------------------------+-- Custom monad and logger actions of different types+----------------------------------------------------------------------------++data Env m = Env+    { envLogString :: LogAction m String+    , envLogInt    :: LogAction m Int+    }++instance HasLog (Env m) String m where+    getLogAction :: Env m -> LogAction m String+    getLogAction = envLogString++    setLogAction :: LogAction m String -> Env m -> Env m+    setLogAction newAction env = env { envLogString = newAction }++instance HasLog (Env m) Int m where+    getLogAction :: Env m -> LogAction m Int+    getLogAction = envLogInt++    setLogAction :: LogAction m Int -> Env m -> Env m+    setLogAction newAction env = env { envLogInt = newAction }++newtype FooM a = FooM+    { runFooM :: ReaderT (Env FooM) IO a+    } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Env FooM))++usingFooM :: Env FooM -> FooM a -> IO a+usingFooM env = flip runReaderT env . runFooM++foo :: (WithLog env String m, WithLog env Int m) => m ()+foo = do+    logMsg ("String message..." :: String)+    logMsg @Int 42++logFoo :: IO ()+logFoo = usingFooM env foo+  where+    env :: Env FooM+    env = Env+        { envLogString = liftLogIO logStringStdout+        , envLogInt    = liftLogIO logPrint+        }++----------------------------------------------------------------------------+-- main runner+----------------------------------------------------------------------------++main :: IO ()+main = withLogTextFile "co-log/example/example.log" $ \logTextFile -> do+    let runApp :: LogAction IO Message -> IO ()+        runApp action = usingLoggerT action app++    let textAction = logTextStdout <> logTextStderr <> logTextFile++    let simpleMessageAction = cmap  fmtMessage            textAction+    let richMessageAction   = cmapM fmtRichMessageDefault textAction++    let fullMessageAction = upgradeMessageAction defaultFieldMap richMessageAction+    let semiMessageAction = upgradeMessageAction+                                (TM.delete @"threadId" defaultFieldMap)+                                richMessageAction++    runApp simpleMessageAction+    runApp fullMessageAction+    runApp semiMessageAction++    usingLoggerT carL $ logMsg $ Car "Toyota" "Corolla" (Pistons 4)++    let pureAction :: PureLogger Message ()+        pureAction = usingLoggerT logMessagePure example+    let ((), msgs) = runPureLog pureAction+    usingLoggerT simpleMessageAction $ logMsgs msgs++    logFoo