diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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) diff --git a/co-log.cabal b/co-log.cabal --- a/co-log.cabal +++ b/co-log.cabal @@ -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 +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 diff --git a/example/Main.hs b/example/Main.hs deleted file mode 100644 --- a/example/Main.hs +++ /dev/null @@ -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 diff --git a/src/Colog.hs b/src/Colog.hs --- a/src/Colog.hs +++ b/src/Colog.hs @@ -1,3 +1,12 @@ +{- | +Copyright: (c) 2018-2019 Kowainik +License: MPL-2.0 +Maintainer: Kowainik + +This package contains @mtl@ implementation of composable, contravariant and +comonadic logging based on @co-log-core@. +-} + module Colog ( module Colog.Actions , module Colog.Core diff --git a/src/Colog/Actions.hs b/src/Colog/Actions.hs --- a/src/Colog/Actions.hs +++ b/src/Colog/Actions.hs @@ -1,6 +1,13 @@ +{- | +Copyright: (c) 2018-2019 Kowainik +License: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Colog/Concurrent.hs b/src/Colog/Concurrent.hs --- a/src/Colog/Concurrent.hs +++ b/src/Colog/Concurrent.hs @@ -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 + +__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. diff --git a/src/Colog/Concurrent/Internal.hs b/src/Colog/Concurrent/Internal.hs --- a/src/Colog/Concurrent/Internal.hs +++ b/src/Colog/Concurrent/Internal.hs @@ -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 + +__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 + } diff --git a/src/Colog/Contra.hs b/src/Colog/Contra.hs --- a/src/Colog/Contra.hs +++ b/src/Colog/Contra.hs @@ -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 + +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 #-} diff --git a/src/Colog/Message.hs b/src/Colog/Message.hs --- a/src/Colog/Message.hs +++ b/src/Colog/Message.hs @@ -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 + +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] \ +@ + +__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] +[Severity] [Time] [SourceLocation] [ThreadId] \ @ + +__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 diff --git a/src/Colog/Monad.hs b/src/Colog/Monad.hs --- a/src/Colog/Monad.hs +++ b/src/Colog/Monad.hs @@ -1,5 +1,13 @@ {-# LANGUAGE InstanceSigs #-} +{- | +Copyright: (c) 2018-2019 Kowainik +License: MPL-2.0 +Maintainer: Kowainik + +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 diff --git a/src/Colog/Pure.hs b/src/Colog/Pure.hs --- a/src/Colog/Pure.hs +++ b/src/Colog/Pure.hs @@ -1,4 +1,9 @@ -{- | Pure implementation of logging action. +{- | +Copyright: (c) 2018-2019 Kowainik +License: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Colog/Rotation.hs b/src/Colog/Rotation.hs --- a/src/Colog/Rotation.hs +++ b/src/Colog/Rotation.hs @@ -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 +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 diff --git a/test/Property.hs b/test/Property.hs new file mode 100644 --- /dev/null +++ b/test/Property.hs @@ -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 diff --git a/tutorials/1-intro/Intro.lhs b/tutorials/1-intro/Intro.lhs new file mode 100644 --- /dev/null +++ b/tutorials/1-intro/Intro.lhs @@ -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 +``` diff --git a/tutorials/2-custom/Custom.lhs b/tutorials/2-custom/Custom.lhs new file mode 100644 --- /dev/null +++ b/tutorials/2-custom/Custom.lhs @@ -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) diff --git a/tutorials/Main.hs b/tutorials/Main.hs new file mode 100644 --- /dev/null +++ b/tutorials/Main.hs @@ -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