co-log-core 0.1.1 → 0.2.0.0

raw patch · 9 files changed

+472/−52 lines, 9 filesdep +GlobPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +78/−0
• co-log-core.cabal +16/−7
• src/Colog/Core.hs +27/−0
• src/Colog/Core/Action.hs +161/−17
• src/Colog/Core/Class.hs +76/−7
• src/Colog/Core/IO.hs +46/−9
• src/Colog/Core/Severity.hs +49/−6
• test/Doctests.hs +8/−6

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

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

@@ -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 <xrom.xkov@gmail.com>+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

@@ -1,3 +1,30 @@+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MIT+Maintainer: Kowainik <xrom.xkov@gmail.com>++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

@@ -1,6 +1,11 @@ {-# LANGUAGE CPP #-} -{- | Implements core data types and combinators for logging actions.+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MIT+Maintainer: Kowainik <xrom.xkov@gmail.com>++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) #-}

@@ -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 <xrom.xkov@gmail.com>++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 #-}

@@ -1,3 +1,15 @@+{- |+Copyright:  (c) 2018-2019 Kowainik+License:    MIT+Maintainer: Kowainik <xrom.xkov@gmail.com>++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 #-}

@@ -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 <xrom.xkov@gmail.com> +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 #-}

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