diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,17 @@ `co-log-core` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. +## 0.1.2.0 — May 5, 2019 + +* [#85](https://github.com/kowainik/co-log/issues/85): + Move `overLogAction` to `HasLog` typeclass +* [#101](https://github.com/kowainik/co-log/issues/101): + Add `logActionL` lens with default implementation to `HasLog` type class. +* [#99](https://github.com/kowainik/co-log/issues/99): + Add comonadic combinators: `duplicate` and `multiplicate`. +* [#78](https://github.com/kowainik/co-log/issues/78): + Improve documentation significantly. + ## 0.1.1 — Nov 15, 2018 * [#63](https://github.com/kowainik/co-log/issues/63): diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,78 @@ +# 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://img.shields.io/travis/kowainik/co-log.svg?logo=travis)](https://travis-ci.org/kowainik/co-log) + +| | | | | +| :------------ | :--------------------------------- | :---------------------------------------- | :---------------------------------------------------- | +| `co-log-core` | [![Hackage][hk-img-core]][hk-core] | [![Stackage LTS][lts-img-core]][lts-core] | [![Stackage Nightly][nightly-img-core]][nightly-core] | +| `co-log` | [![Hackage][hk-img]][hk] | [![Stackage LTS][lts-img]][lts] | [![Stackage Nightly][nightly-img]][nightly] | +| `co-log-polysemy` | [![Hackage][hk-img-ps]][hk-ps] | [![Stackage LTS][lts-img-ps]][lts-ps] | [![Stackage Nightly][nightly-img-ps]][nightly-ps] | + +`co-log` is a composable and configurable logging framework. The idea of the approach is +described in the following blog post: + +* [co-log: Composable Contravariant Combinatorial Comonadic Configurable Convenient Logging](https://kowainik.github.io/posts/2018-09-25-co-log) + +The repository contains the following packages: + +* [`co-log-core`](co-log-core): lightweight package with basic data types and + general idea. +* [`co-log`](co-log): taggless final implementation of logging library based on + `co-log-core`. +* [`co-log-polysemy`](co-log-polysemy): implementation of logging library based + on `co-log-core` and the [`polysemy`](http://hackage.haskell.org/package/polysemy) extensible effects library. +* [`co-log-benchmark`](co-log-benchmark): Benchmarks of the `co-log` library. + +See the following tutorial series about the library: + +* [Intro: Using `LogAction`](https://github.com/kowainik/co-log/blob/master/co-log/tutorials/1-intro/Intro.md) +* [Using custom monad that stores `LogAction` inside its environment](https://github.com/kowainik/co-log/blob/master/co-log/tutorials/2-custom/Custom.md) + +## Benchmarks + +`co-log` is compared with basic functions like `putStrLn`. Since IO overhead is +big enough, every benchmark dumps 10K messages to output. If benchmark name +doesn't contain `Message` then this benchmark simply dumps string `"message"` +to output, otherwise it works with `Message` data type from the `co-log` +library. + +| Benchmarks | Time for 10K messages | +| :------------------------------------------------------ | :-------------------- | +| `Prelude.putStrLn` | ` 5.117ms` | +| `Text.putStrLn` | ` 9.220ms` | +| `ByteString.putStrLn` | ` 2.971ms` | +| `mempty` | ` 1.181ms` | +| `logStringStdout` | ` 5.107ms` | +| `logPrint` | ` 5.248ms` | +| `logTextStdout` | ` 5.351ms` | +| `logByteStringStdout` | ` 2.933ms` | +| `logByteStringStderr` | ` 17.482ms` | +| `ByteString > (stdout <> stderr)` | ` 17.715ms` | +| `Message > format > stdout` | ` 9.188ms` | +| `Message > format > ByteString > stdout` | ` 3.524ms` | +| `Message{callstack} > format > stdout` | ` 9.139ms` | +| `Message{callstack:5} > format > stdout` | ` 9.464ms` | +| `Message{callstack:50} > format > stdout` | ` 9.439ms` | +| `Message{Time,ThreadId} > format > stdout` | ` 54.160ms` | +| `Message{Time,ThreadId} > format > ByteString > stdout` | ` 54.137ms` | + + +[hk-img]: https://img.shields.io/hackage/v/co-log.svg?logo=haskell +[hk-img-ps]: https://img.shields.io/hackage/v/co-log-polysemy.svg?logo=haskell +[hk-img-core]: https://img.shields.io/hackage/v/co-log-core.svg?logo=haskell +[hk]: https://hackage.haskell.org/package/co-log +[hk-ps]: https://hackage.haskell.org/package/co-log-polysemy +[hk-core]: https://hackage.haskell.org/package/co-log-core +[lts-img]: http://stackage.org/package/co-log/badge/lts +[lts-img-ps]: http://stackage.org/package/co-log-polysemy/badge/lts +[lts-img-core]: http://stackage.org/package/co-log-core/badge/lts +[lts]: http://stackage.org/lts/package/co-log +[lts-ps]: http://stackage.org/lts/package/co-log-polysemy +[lts-core]: http://stackage.org/lts/package/co-log-core +[nightly-img]: http://stackage.org/package/co-log/badge/nightly +[nightly-img-ps]: http://stackage.org/package/co-log-polysemy/badge/nightly +[nightly-img-core]: http://stackage.org/package/co-log-core/badge/nightly +[nightly]: http://stackage.org/nightly/package/co-log +[nightly-ps]: http://stackage.org/nightly/package/co-log-polysemy +[nightly-core]: http://stackage.org/nightly/package/co-log-core diff --git a/co-log-core.cabal b/co-log-core.cabal --- a/co-log-core.cabal +++ b/co-log-core.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: co-log-core -version: 0.1.1 +version: 0.2.0.0 synopsis: Composable Contravariant Comonadic Logging Library description: This package provides core types and functions to work with the @LogAction@ data type which is both simple and powerful. @@ -14,20 +14,28 @@ The ideas behind this package are described in the following blog post: . * [co-log: Composable Contravariant Combinatorial Comonadic Configurable Convenient Logging](https://kowainik.github.io/posts/2018-09-25-co-log) + . + See the following packages for different implementations based on @co-log-core@: + . + * [co-log](http://hackage.haskell.org/package/co-log): taggless final implementations. + * [co-log-polysemy](http://hackage.haskell.org/package/co-log-polysemy): extensible + effects implementation based on @polysemy@. homepage: https://github.com/kowainik/co-log bug-reports: https://github.com/kowainik/co-log/issues license: MPL-2.0 license-file: LICENSE -author: Kowainik -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: stable 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 @@ -70,6 +78,7 @@ type: exitcode-stdio-1.0 build-depends: base >= 4.10 && < 4.13 , doctest ^>= 0.16.0 + , Glob default-language: Haskell2010 hs-source-dirs: test main-is: Doctests.hs diff --git a/src/Colog/Core.hs b/src/Colog/Core.hs --- a/src/Colog/Core.hs +++ b/src/Colog/Core.hs @@ -1,3 +1,30 @@ +{- | +Copyright: (c) 2018-2019 Kowainik +License: MIT +Maintainer: Kowainik + +Exports all core functionality. @co-log-core@ is a lightweight package that +defines only core data type and various combinators to work with it. + +Fundamentals of @co-log-core@ are based on the following data type: + +@ +__newtype__ LogAction m msg = LogAction + { unLogAction :: msg -> m () + } +@ + +This data type provides extremely composable and flexible interface by having +many instances of the standard algebraic data types. + +The package has the following structure: + +* __"Colog.Core.Action":__ definition of the main data type and its combinators. +* __"Colog.Core.Class":__ 'HasLog' typeclass that describes how different values + (e.g. application environment) can store and modify 'LogAction'. +* __"Colog.Core.IO":__ basic loggers that work with 'Control.Monad.IO.Class.MonadIO' and 'String'. +* __"Colog.Core.Severity":__ logger severity. +-} module Colog.Core ( module Colog.Core.Action , module Colog.Core.Class diff --git a/src/Colog/Core/Action.hs b/src/Colog/Core/Action.hs --- a/src/Colog/Core/Action.hs +++ b/src/Colog/Core/Action.hs @@ -1,6 +1,11 @@ {-# LANGUAGE CPP #-} -{- | Implements core data types and combinators for logging actions. +{- | +Copyright: (c) 2018-2019 Kowainik +License: MIT +Maintainer: Kowainik + +Implements core data types and combinators for logging actions. -} module Colog.Core.Action @@ -13,13 +18,16 @@ , foldActions -- * Contravariant combinators + -- $contravariant , cfilter , cmap , (>$<) + , cmapMaybe , (Colog.Core.Action.>$) , cmapM -- * Divisible combinators + -- $divisible , divide , conquer , (>*<) @@ -27,20 +35,24 @@ , (*<) -- * Decidable combinators + -- $decidable , lose , choose , (>|<) -- * Comonadic combinators + -- $comonad , extract , extend , (=>>) , (<<=) + , duplicate + , multiplicate ) where import Control.Monad (when, (>=>)) import Data.Coerce (coerce) -import Data.Foldable (for_) +import Data.Foldable (fold, for_) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..), stimesMonoid) @@ -69,8 +81,11 @@ Key design point here is that 'LogAction' is: * 'Semigroup' -* Contravariant -* Comonad +* 'Monoid' +* 'Data.Functor.Contravariant.Contravariant' +* 'Data.Functor.Contravariant.Divisible.Divisible' +* 'Data.Functor.Contravariant.Divisible.Decidable' +* 'Control.Comonad.Comonad' -} newtype LogAction m msg = LogAction { unLogAction :: msg -> m () @@ -136,7 +151,7 @@ doesn't make sense. Instead you want: @ -action <& msg1 >> action <& msg2 +action <& msg1 \>\> action <& msg2 @ In addition, because '<&' has higher precedence than the other operators in this @@ -168,13 +183,9 @@ -} infix 5 &> (&>) :: msg -> LogAction m msg -> m () -(&>) = flip unLogAction +(&>) = flip (<&) {-# INLINE (&>) #-} ----------------------------------------------------------------------------- --- Combinators ----------------------------------------------------------------------------- - {- | Joins some 'Foldable' of 'LogAction's into single 'LogAction' using 'Semigroup' instance for 'LogAction'. This is basically specialized version of 'Data.Foldable.fold' function. @@ -185,6 +196,20 @@ {-# SPECIALIZE foldActions :: Applicative m => [LogAction m a] -> LogAction m a #-} {-# SPECIALIZE foldActions :: Applicative m => NonEmpty (LogAction m a) -> LogAction m a #-} +---------------------------------------------------------------------------- +-- Contravariant combinators +---------------------------------------------------------------------------- + +{- $contravariant + +Combinators that implement interface in the spirit of the following typeclass: + +@ +__class__ Contravariant f __where__ + contramap :: (a -> b) -> f b -> f a +@ +-} + {- | Takes predicate and performs given logging action only if predicate returns 'True' on input logging message. -} @@ -244,6 +269,11 @@ (>$<) = cmap {-# INLINE (>$<) #-} +-- | 'cmap' for convertions that may fail +cmapMaybe :: Applicative m => (a -> Maybe b) -> LogAction m b -> LogAction m a +cmapMaybe f (LogAction action) = LogAction (maybe (pure ()) action . f) +{-# INLINE cmapMaybe #-} + {- | This combinator is @>$@ from contravariant functor. Replaces all locations in the output with the same value. The default definition is @contramap . const@, so this is a more efficient version. @@ -303,6 +333,21 @@ cmapM f (LogAction action) = LogAction (f >=> action) {-# INLINE cmapM #-} +---------------------------------------------------------------------------- +-- Divisible combinators +---------------------------------------------------------------------------- + +{- $divisible + +Combinators that implement interface in the spirit of the following typeclass: + +@ +__class__ Contravariant f => Divisible f __where__ + conquer :: f a + divide :: (a -> (b, c)) -> f b -> f c -> f a +@ +-} + {- | @divide@ combinator from @Divisible@ type class. >>> logInt = LogAction print @@ -313,6 +358,7 @@ divide :: (Applicative m) => (a -> (b, c)) -> LogAction m b -> LogAction m c -> LogAction m a divide f (LogAction actionB) (LogAction actionC) = LogAction $ \(f -> (b, c)) -> actionB b *> actionC c +{-# INLINE divide #-} {- | @conquer@ combinator from @Divisible@ type class. @@ -323,7 +369,7 @@ -} conquer :: Applicative m => LogAction m a conquer = mempty - +{-# INLINE conquer #-} {- | Operator version of @'divide' 'id'@. @@ -341,7 +387,6 @@ actionA a *> actionB b {-# INLINE (>*<) #-} -infixr 4 >* {-| Perform a constant log action after another. >>> logHello = LogAction (const (putStrLn "Hello!")) @@ -349,21 +394,38 @@ Greetings! Hello! -} +infixr 4 >* (>*) :: Applicative m => LogAction m a -> LogAction m () -> LogAction m a (LogAction actionA) >* (LogAction actionB) = LogAction $ \a -> actionA a *> actionB () {-# INLINE (>*) #-} -infixr 4 *< -- | A flipped version of '>*' +infixr 4 *< (*<) :: Applicative m => LogAction m () -> LogAction m a -> LogAction m a (LogAction actionA) *< (LogAction actionB) = LogAction $ \a -> actionA () *> actionB a {-# INLINE (*<) #-} +---------------------------------------------------------------------------- +-- Decidable combinators +---------------------------------------------------------------------------- + +{- $decidable + +Combinators that implement interface in the spirit of the following typeclass: + +@ +__class__ Divisible f => Decidable f __where__ + lose :: (a -> Void) -> f a + choose :: (a -> Either b c) -> f b -> f c -> f a +@ +-} + -- | @lose@ combinator from @Decidable@ type class. lose :: (a -> Void) -> LogAction m a lose f = LogAction (absurd . f) +{-# INLINE lose #-} {- | @choose@ combinator from @Decidable@ type class. @@ -376,6 +438,7 @@ -} choose :: (a -> Either b c) -> LogAction m b -> LogAction m c -> LogAction m a choose f (LogAction actionB) (LogAction actionC) = LogAction (either actionB actionC . f) +{-# INLINE choose #-} {- | Operator version of @'choose' 'id'@. @@ -390,6 +453,22 @@ (LogAction actionA) >|< (LogAction actionB) = LogAction (either actionA actionB) {-# INLINE (>|<) #-} +---------------------------------------------------------------------------- +-- Comonadic combinators +---------------------------------------------------------------------------- + +{- $comonad + +Combinators that implement interface in the spirit of the following typeclass: + +@ +__class__ Functor w => Comonad w __where__ + extract :: w a -> a + duplicate :: w a -> w (w a) + extend :: (w a -> b) -> w a -> w b +@ +-} + {- | If @msg@ is 'Monoid' then 'extract' performs given log action by passing 'mempty' to it. @@ -399,26 +478,28 @@ -} extract :: Monoid msg => LogAction m msg -> m () extract action = unLogAction action mempty +{-# INLINE extract #-} -- TODO: write better motivation for comonads {- | This is a /comonadic extend/. It allows you to chain different transformations on messages. >>> f (LogAction l) = l ".f1" *> l ".f2" >>> g (LogAction l) = l ".g" ->>> unLogAction logStringStdout "foo" +>>> logStringStdout <& "foo" foo ->>> unLogAction (extend f logStringStdout) "foo" +>>> extend f logStringStdout <& "foo" foo.f1 foo.f2 ->>> unLogAction (extend g $ extend f logStringStdout) "foo" +>>> (extend g $ extend f logStringStdout) <& "foo" foo.g.f1 foo.g.f2 ->>> unLogAction (logStringStdout =>> f =>> g) "foo" +>>> (logStringStdout =>> f =>> g) <& "foo" foo.g.f1 foo.g.f2 -} extend :: Semigroup msg => (LogAction m msg -> m ()) -> LogAction m msg -> LogAction m msg extend f (LogAction action) = LogAction $ \m -> f $ LogAction $ \m' -> action (m <> m') +{-# INLINE extend #-} -- | 'extend' with the arguments swapped. Dual to '>>=' for a 'Monad'. infixl 1 =>> @@ -431,3 +512,66 @@ (<<=) :: Semigroup msg => (LogAction m msg -> m ()) -> LogAction m msg -> LogAction m msg (<<=) = extend {-# INLINE (<<=) #-} + +{- | Converts any 'LogAction' that can log single message to the 'LogAction' +that can log two messages. The new 'LogAction' behaves in the following way: + +1. Joins two messages of type @msg@ using '<>' operator from 'Semigroup'. +2. Passes resulted message to the given 'LogAction'. + +>>> :{ +let logger :: LogAction IO [Int] + logger = logPrint +in duplicate logger <& ([3, 4], [42, 10]) +:} +[3,4,42,10] + +__Implementation note:__ + +True and fair translation of the @duplicate@ function from the 'Control.Comonad.Comonad' +interface should result in the 'LogAction' of the following form: + +@ +msg -> msg -> m () +@ + +In order to capture this behavior, 'duplicate' should have the following type: + +@ +duplicate :: Semigroup msg => LogAction m msg -> LogAction (Compose ((->) msg) m) msg +@ + +However, it's quite awkward to work with such type. It's a known fact that the +following two types are isomorphic (see functions 'curry' and 'uncurry'): + +@ +a -> b -> c +(a, b) -> c +@ + +So using this fact we can come up with the simpler interface. +-} +duplicate :: forall msg m . Semigroup msg => LogAction m msg -> LogAction m (msg, msg) +duplicate (LogAction l) = LogAction $ \(msg1, msg2) -> l (msg1 <> msg2) +{-# INLINE duplicate #-} + + +{- | Like 'duplicate' but why stop on a pair of two messages if you can log any +'Foldable' of messages? + +>>> :{ +let logger :: LogAction IO [Int] + logger = logPrint +in multiplicate logger <& replicate 5 [1..3] +:} +[1,2,3,1,2,3,1,2,3,1,2,3,1,2,3] +-} +multiplicate + :: forall f msg m . + (Foldable f, Monoid msg) + => LogAction m msg + -> LogAction m (f msg) +multiplicate (LogAction l) = LogAction $ \msgs -> l (fold msgs) +{-# INLINE multiplicate #-} +{-# SPECIALIZE multiplicate :: Monoid msg => LogAction m msg -> LogAction m [msg] #-} +{-# SPECIALIZE multiplicate :: Monoid msg => LogAction m msg -> LogAction m (NonEmpty msg) #-} diff --git a/src/Colog/Core/Class.hs b/src/Colog/Core/Class.hs --- a/src/Colog/Core/Class.hs +++ b/src/Colog/Core/Class.hs @@ -1,28 +1,97 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} -{- | Provides type class for objects that has access to 'LogAction'. +{- | +Copyright: (c) 2018-2019 Kowainik +License: MIT +Maintainer: Kowainik + +Provides type class for values that has access to 'LogAction'. -} module Colog.Core.Class ( HasLog (..) - , overLogAction + + -- * Lens + -- $lens + , Lens' ) where import Colog.Core.Action (LogAction) -{- | This types class contains simple pair of getter-setter. -TODO: laws +-- to inline lens better +{- HLINT ignore "Redundant lambda" -} + +{- | This types class contains simple pair of getter-setter and related +functions. +It also provides the useful lens 'logActionL' with the default implementation using type +class methods. The default one could be easily overritten under your instances. + +Every instance of the this typeclass should satisfy the following laws: + +1. __Set-Get:__ @'getLogAction' ('setLogAction' l env) ≡ l@ +2. __Get-Set:__ @'setLogAction' ('getLogAction' env) env ≡ env@ +3. __Set-Set:__ @'setLogAction' l2 ('setLogAction' l1 env) ≡ 'setLogAction' l2 env@ +4. __Set-Over:__ @'overLogAction' f env ≡ 'setLogAction' (f $ 'getLogAction' env) env@ -} class HasLog env msg m where + {-# MINIMAL getLogAction, (setLogAction | overLogAction) #-} + + -- | Extracts 'LogAction' from the environment. getLogAction :: env -> LogAction m msg + + -- | Sets 'LogAction' to the given one inside the environment. setLogAction :: LogAction m msg -> env -> env + setLogAction = overLogAction . const + {-# INLINE setLogAction #-} + -- | Applies function to the 'LogAction' inside the environment. + overLogAction :: (LogAction m msg -> LogAction m msg) -> env -> env + overLogAction f env = setLogAction (f $ getLogAction env) env + {-# INLINE overLogAction #-} + + -- | Lens for 'LogAction' inside the environment. + logActionL :: Lens' env (LogAction m msg) + logActionL = lens getLogAction (flip setLogAction) + {-# INLINE logActionL #-} + instance HasLog (LogAction m msg) msg m where + getLogAction :: LogAction m msg -> LogAction m msg getLogAction = id + {-# INLINE getLogAction #-} + + setLogAction :: LogAction m msg -> LogAction m msg -> LogAction m msg setLogAction = const + {-# INLINE setLogAction #-} -overLogAction :: HasLog env msg m => (LogAction m msg -> LogAction m msg) -> env -> env -overLogAction over env = setLogAction (over $ getLogAction env) env -{-# INLINE overLogAction #-} + overLogAction + :: (LogAction m msg -> LogAction m msg) + -> LogAction m msg + -> LogAction m msg + overLogAction = id + {-# INLINE overLogAction #-} + + logActionL :: Lens' (LogAction m msg) (LogAction m msg) + logActionL = \f s -> s <$ f s + {-# INLINE logActionL #-} + +---------------------------------------------------------------------------- +-- Lens +---------------------------------------------------------------------------- + +{- $lens +To keep @co-log-core@ a lightweight library it was decided to introduce local +'Lens'' type alias as it doesn't harm. +-} + +{- | The monomorphic lenses which don't change the type of the container (or of +the value inside). +-} +type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s + +-- | Creates 'Lens'' from the getter and setter. +lens :: (s -> a) -> (s -> a -> s) -> Lens' s a +lens getter setter = \f s -> setter s <$> f (getter s) +{-# INLINE lens #-} diff --git a/src/Colog/Core/IO.hs b/src/Colog/Core/IO.hs --- a/src/Colog/Core/IO.hs +++ b/src/Colog/Core/IO.hs @@ -1,3 +1,15 @@ +{- | +Copyright: (c) 2018-2019 Kowainik +License: MIT +Maintainer: Kowainik + +Introduces logging actions working in 'MonadIO'. These actions are very basic +and inefficient because they use the 'String' data type. If you don't want to +have extra dependencies and performance of logging is not the bottleneck of your +application, then these functions should be enough. Otherwise use functions from +the "Colog.Actions" module from the @co-log@ package. +-} + module Colog.Core.IO ( -- * 'String' actions logStringStdout @@ -19,33 +31,43 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import System.IO (Handle, IOMode (AppendMode), hPrint, hPutStrLn, stderr, withFile) +{- $setup +>>> import Colog.Core.Action +-} + ---------------------------------------------------------------------------- -- String ---------------------------------------------------------------------------- {- | Action that prints 'String' to stdout. ->>> unLogAction logStringStdout "foo" +>>> logStringStdout <& "foo" foo -} logStringStdout :: MonadIO m => LogAction m String logStringStdout = LogAction (liftIO . putStrLn) +{-# INLINE logStringStdout #-} +{-# SPECIALIZE logStringStdout :: LogAction IO String #-} {- | Action that prints 'String' to stderr. ->>> unLogAction logStringStderr "foo" +>>> logStringStderr <& "foo" foo -} logStringStderr :: MonadIO m => LogAction m String logStringStderr = logStringHandle stderr +{-# INLINE logStringStderr #-} +{-# SPECIALIZE logStringStderr :: LogAction IO String #-} {- | Action that prints 'String' to 'Handle'. ->>> unLogAction (logStringHandle stderr) "foo" +>>> logStringHandle stderr <& "foo" foo -} logStringHandle :: MonadIO m => Handle -> LogAction m String logStringHandle handle = LogAction $ liftIO . hPutStrLn handle +{-# INLINE logStringHandle #-} +{-# SPECIALIZE logStringHandle :: Handle -> LogAction IO String #-} {- | Action that prints 'String' to file. Instead of returning 'LogAction' it's implemented in continuation-passing style because it's more efficient to open @@ -54,12 +76,14 @@ Opens file in 'AppendMode'. ->>> logger action = unLogAction action "foo" +>>> logger action = action <& "foo" >>> withLogStringFile "/dev/stdout" logger foo -} withLogStringFile :: MonadIO m => FilePath -> (LogAction m String -> IO r) -> IO r withLogStringFile path action = withFile path AppendMode $ action . logStringHandle +{-# INLINE withLogStringFile #-} +{-# SPECIALIZE withLogStringFile :: FilePath -> (LogAction IO String -> IO r) -> IO r #-} ---------------------------------------------------------------------------- -- Show @@ -67,32 +91,44 @@ {- | Action that prints to stdout using 'Show'. ->>> unLogAction logPrint 5 +>>> logPrint <& 5 5 -} logPrint :: forall a m . (Show a, MonadIO m) => LogAction m a logPrint = LogAction $ liftIO . print +{-# INLINE logPrint #-} +{-# SPECIALIZE logPrint :: Show a => LogAction IO a #-} {- | Action that prints to stderr using 'Show'. ->>> unLogAction logPrintStderr 5 +>>> logPrintStderr <& 5 5 -} logPrintStderr :: forall a m . (Show a, MonadIO m) => LogAction m a logPrintStderr = logPrintHandle stderr +{-# INLINE logPrintStderr #-} +{-# SPECIALIZE logPrintStderr :: Show a => LogAction IO a #-} {- | Action that prints to a 'Handle' using 'Show'. ->>> unLogAction (logPrintHandle stderr) 5 +>>> logPrintHandle stderr <& 5 5 -} logPrintHandle :: forall a m . (Show a, MonadIO m) => Handle -> LogAction m a logPrintHandle handle = LogAction $ liftIO . hPrint handle +{-# INLINE logPrintHandle #-} +{-# SPECIALIZE logPrintHandle :: Show a => Handle -> LogAction IO a #-} {- | Action that prints to a file using 'Show'. See 'withLogStringFile' for details. -} -withLogPrintFile :: forall a m r . (Show a, MonadIO m) => FilePath -> (LogAction m a -> IO r) -> IO r +withLogPrintFile + :: forall a m r . (Show a, MonadIO m) + => FilePath + -> (LogAction m a -> IO r) + -> IO r withLogPrintFile path action = withFile path AppendMode $ action . logPrintHandle +{-# INLINE withLogPrintFile #-} +{-# SPECIALIZE withLogPrintFile :: Show a => FilePath -> (LogAction IO a -> IO r) -> IO r #-} ---------------------------------------------------------------------------- -- Misc @@ -101,8 +137,9 @@ {- | Lifts a LogAction over IO into a more general Monad. >>> logToStdout = LogAction putStrLn ->>> unLogAction (liftLogIO logToStdout) "foo" +>>> liftLogIO logToStdout <& "foo" foo -} liftLogIO :: MonadIO m => LogAction IO msg -> LogAction m msg liftLogIO (LogAction action) = LogAction (liftIO . action) +{-# INLINE liftLogIO #-} diff --git a/src/Colog/Core/Severity.hs b/src/Colog/Core/Severity.hs --- a/src/Colog/Core/Severity.hs +++ b/src/Colog/Core/Severity.hs @@ -1,13 +1,31 @@ {-# LANGUAGE PatternSynonyms #-} -{- | This module introduces 'Severity' data type for expressing how severe the -message is. Also, it contains useful functions for work with 'Severity'. +{- | +Copyright: (c) 2018-2019 Kowainik +License: MIT +Maintainer: Kowainik +This module introduces 'Severity' data type for expressing how severe the +message is. Also, it contains useful functions and patterns for work with 'Severity'. + + + +-----------+---------+-----------------------------------------+-----------------------------+ + | Severity | Pattern | Meaning | Example | + +===========+=========+=========================================+=============================+ + | 'Debug' | 'D' | Information useful for debug purposes | Internal function call logs | + +-----------+---------+-----------------------------------------+-----------------------------+ + | 'Info' | 'I' | Normal operational information | Finish file uploading | + +-----------+---------+-----------------------------------------+-----------------------------+ + | 'Warning' | 'W' | General warnings, non-critical failures | Image load error | + +-----------+---------+-----------------------------------------+-----------------------------+ + | 'Error' | 'E' | General errors/severe errors | Could not connect to the DB | + +-----------+---------+-----------------------------------------+-----------------------------+ -} module Colog.Core.Severity ( Severity (..) - -- Patterns + -- ** Patterns + -- $pattern , pattern D , pattern I , pattern W @@ -44,6 +62,26 @@ | Error deriving (Show, Read, Eq, Ord, Enum, Bounded, Ix) +{- $pattern +Instead of using full names of the constructors you can instead use one-letter +patterns. To do so you can import and use the pattern: + +@ +__import__ Colog (__pattern__ D) + +example :: WithLog env Message m => m () +example = log D "I'm using severity pattern" +@ + +Moreover, you could use patterns when pattern-matching on severity + +@ +errorToStderr :: 'Severity' -> IO () +errorToStderr E = hputStrLn stderr "Error severity" +errorToStderr _ = putStrLn "Something else" +@ +-} + pattern D, I, W, E :: Severity pattern D <- Debug where D = Debug pattern I <- Info where I = Info @@ -51,7 +89,12 @@ pattern E <- Error where E = Error {-# COMPLETE D, I, W, E #-} - --- | Filters messages by given 'Severity'. -filterBySeverity :: Applicative m => Severity -> (a -> Severity) -> LogAction m a -> LogAction m a +-- | Filters messages by the given 'Severity'. +filterBySeverity + :: Applicative m + => Severity + -> (a -> Severity) + -> LogAction m a + -> LogAction m a filterBySeverity s fs = cfilter (\a -> fs a >= s) +{-# INLINE filterBySeverity #-} diff --git a/test/Doctests.hs b/test/Doctests.hs --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -2,12 +2,14 @@ ( main ) where +import System.FilePath.Glob (glob) import Test.DocTest (doctest) main :: IO () -main = doctest - [ "-XInstanceSigs" - , "-XScopedTypeVariables" - , "-XViewPatterns" - , "src" - ] +main = do + sourceFiles <- glob "co-log-core/src/**/*.hs" + doctest + $ "-XInstanceSigs" + : "-XScopedTypeVariables" + : "-XViewPatterns" + : sourceFiles