Add WithSeverity

CHANGELOG.md

@@ -3,6 +3,10 @@
 `co-log-core` uses [PVP Versioning][1].
 The change log is available [on GitHub][2].
 
+## Unreleased
+
+* Added `WithSeverity` and `mapSeverity` to `Colog.Severity`.
+
 ## 🎃 0.3.0.0 — Oct 29, 2021
 
 * [#223](https://github.com/co-log/co-log/pull/223):

co-log-core.cabal

@@ -66,6 +66,8 @@ common common-options
 
   default-language:    Haskell2010
   default-extensions:  ConstraintKinds
+                       DeriveFunctor
+                       DeriveTraversable
                        DeriveGeneric
                        DerivingStrategies
                        GeneralizedNewtypeDeriving

src/Colog/Core/Severity.hs

@@ -34,6 +34,8 @@ module Colog.Core.Severity
        , pattern W
        , pattern E
        , filterBySeverity
+       , WithSeverity (..)
+       , mapSeverity
        ) where
 
 import Data.Ix (Ix)
@@ -102,3 +104,36 @@ filterBySeverity
     -> LogAction m a
 filterBySeverity s fs = cfilter (\a -> fs a >= s)
 {-# INLINE filterBySeverity #-}
+
+-- Note: the order of the fields here is to allow the constructor to be used infix.
+{-| A message tagged with a 'Severity'.
+
+It is common to want to log various types of messages tagged with a severity. 
+'WithSeverity' provides a standard way to do so while allowing the messages to be processed independently of the severity.
+
+It is easy to 'cmap' over a 'LogAction m (WithSeverity a)', or to filter based on the severity.
+
+@
+logSomething :: LogAction m (WithSeverity String) -> m ()
+logSomething logger = logger <& "hello" `WithSeverity` Info
+
+cmap' :: (b -> a) -> LogAction m (WithSeverity a) -> LogAction m (WithSeverity b)
+cmap' f action = cmap (fmap f) action
+
+filterBySeverity' :: (Applicative m) => Severity -> LogAction m (WithSeverity a) -> LogAction m (WithSeverity a)
+filterBySeverity' threshold action = filterBySeverity threshold getSeverity action
+@
+-}
+data WithSeverity msg = WithSeverity { getMsg :: msg , getSeverity :: Severity }
+  deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+{- | Map the given function over the severity of a 'WithSeverity'.
+
+This can be useful to operate generically over the severity, for example:
+@
+suppressErrors :: LogAction m (WithSeverity msg) -> LogAction m (WithSeverity msg)
+suppressErrors = cmap (mapSeverity (\s -> if s == Error then Warning else s))
+@
+-}
+mapSeverity :: (Severity -> Severity) -> WithSeverity msg -> WithSeverity msg
+mapSeverity f (WithSeverity msg sev) = WithSeverity msg (f sev)