plow-log (empty) → 0.1.6.0
raw patch · 7 files changed
+351/−0 lines, 7 filesdep +aesondep +basedep +text
Dependencies added: aeson, base, text
Files
- CHANGELOG.md +24/−0
- LICENSE +21/−0
- plow-log.cabal +35/−0
- src/Plow/Logging.hs +121/−0
- src/Plow/Logging/EnumerableConstructors.hs +80/−0
- src/Plow/Logging/Message.hs +53/−0
- src/Plow/Throwing.hs +17/−0
+ CHANGELOG.md view
@@ -0,0 +1,24 @@+# Revision history for plow-log++## 0.1.6.0 -- 2022-11-23+* Prep for OSS release++## 0.1.5.0 -- 2022-10-31+* Add instance Semigroup (LogMessage String).+* Add Aeson instances for LogMessage.++## 0.1.4.0 -- 2022-08-19+* Add Plow.Logging.Message.++## 0.1.3.0 -- 2022-1-10+* Added Semigroup and Monoid instances for Tracer++## 0.1.2.0 -- 2021-7-23+* Added simpleStdErrLogger and a new withEitherTracer function for combining two loggers++## 0.1.1.0 -- 2021-3-18+* Cleanup in Logging and added separate Plow.Throwing++## 0.1.0.0 -- 2021-3-17++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Plow Technologies++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ plow-log.cabal view
@@ -0,0 +1,35 @@+cabal-version: >=1.10+name: plow-log+version: 0.1.6.0+synopsis: Contravariant logging library+description: Contravariant logging library agnostic to the logging backend+category: Logging+homepage: https://github.com/plow-technologies/plow-log.git#readme+bug-reports: https://github.com/plow-technologies/plow-log.git/issues+copyright: Plow-Technologies LLC+license: MIT+license-file: LICENSE+author: Sam Balco+maintainer: samuel.balco@plowtech.net+build-type: Simple+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/plow-technologies/plow-log.git++library+ exposed-modules:+ Plow.Logging+ , Plow.Logging.Message+ , Plow.Throwing+ other-modules:+ Plow.Logging.EnumerableConstructors+ hs-source-dirs:+ src+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+ build-depends:+ base >= 4.13 && < 4.18+ , aeson >= 2.1.1 && < 2.2+ , text >= 1.2.5 && < 2.1+ default-language: Haskell2010
+ src/Plow/Logging.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++module Plow.Logging+ ( Tracer (..),+ traceWith,+ HasEnumerableConstructors,+ invalidSilencedConstructors,+ warnInvalidSilencedConstructorsWith,+ withSilencedTracer,+ withAllowedTracer,+ withMaybeTracer,+ withEitherTracer,+ filterTracer,+ simpleStdOutTracer,+ simpleStdErrTracer,+ voidTracer,+ IOTracer (..),+ )+where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Functor.Contravariant (Contravariant (..))+import Data.List (intercalate, intersect)+import Data.Proxy (Proxy)+import Data.String (IsString (..))+import Plow.Logging.EnumerableConstructors+import System.IO (hPutStrLn, stderr)++newtype Tracer m a = Tracer (a -> m ())++instance Monad m => Semigroup (Tracer m a) where+ (Tracer f) <> (Tracer g) = Tracer $ \a -> f a >> g a++instance Monad m => Monoid (Tracer m a) where+ mempty = Tracer $ \_ -> pure ()++class TraceWith x m where+ traceWith :: x a -> a -> m ()++instance TraceWith (Tracer m) m where+ traceWith (Tracer t) = t++instance Contravariant (Tracer m) where+ contramap f (Tracer t) = Tracer (t . f)++invalidSilencedConstructors :: HasEnumerableConstructors a => Proxy a -> [String] -> [String]+invalidSilencedConstructors p silencedConstructors =+ let cs = allConstructors p+ in filter (\c -> not $ c `elem` cs) silencedConstructors++-- | Given a "string-like" tracer, outputs a warning message if the supplied 'silencedConstructors' do not+-- match the output of 'allConstructors' for the given tracer type 'a'+warnInvalidSilencedConstructorsWith :: (Applicative m, HasEnumerableConstructors a, IsString s) => Proxy a -> [String] -> Tracer m s -> m ()+warnInvalidSilencedConstructorsWith p silencedConstructors t = case invalidSilencedConstructors p silencedConstructors of+ [] -> pure ()+ invalid -> traceWith t $ fromString $ "Detected invalid silenced logging options: " <> intercalate ", " invalid++filterTracer :: Applicative m => (a -> Bool) -> Tracer m a -> Tracer m a+filterTracer test (Tracer f) = Tracer $ \m -> when (test m) (f m)++-- | Modifies a given tracer so that any message with a constructor name appearing in 'silencedConstructors'+-- will be discarded. In order to work as expected, the type 'a' is required to have an automatically+-- derived instance of 'HasEnumerableConstructors'.+-- @+-- data Foo = Florb Int | Fleeb String | Bar Bool deriving (Generic, HasEnumerableConstructors)+-- @+-- then calling+-- > traceWith (withSilencedTracer ["Bar"] t) $ Bar False+-- is equivalent to+-- > pure ()+-- and+-- > traceWith (withSilencedTracer ["Bar"] t) $ Florb 3+-- will be definitionally equal to+-- > traceWith t $ Florb 3+withSilencedTracer :: (Applicative m, HasEnumerableConstructors a) => [String] -> Tracer m a -> Tracer m a+withSilencedTracer silencedConstructors = filterTracer (\m -> null $ listConstructors m `intersect` silencedConstructors)++-- | The opposite of 'withSilencedTracer'. This tracer only loggs messages which match a constructor in+-- 'allowedConstructors'.+withAllowedTracer :: (Applicative m, HasEnumerableConstructors a) => [String] -> Tracer m a -> Tracer m a+withAllowedTracer allowedConstructors = filterTracer (\m -> not $ null $ listConstructors m `intersect` allowedConstructors)++-- | Turns a tracer for some 'a' into a tracer for 'Maybe a', which traces 'Just x' using the original tracer+-- | and ignores 'Nothing' (i.e. 'pure ()')+withMaybeTracer :: Applicative m => Tracer m a -> Tracer m (Maybe a)+withMaybeTracer (Tracer t) = Tracer (maybe (pure ()) t)++-- | Takes two tracers for values 'a' and 'b' to a tracer for 'Either a b', which selects the appropriate tracer for each value+withEitherTracer :: Applicative m => Tracer m a -> Tracer m b -> Tracer m (Either a b)+withEitherTracer (Tracer ta) (Tracer tb) = Tracer $ \case+ Left a -> ta a+ Right b -> tb b++simpleStdOutTracer :: MonadIO m => Tracer m String+simpleStdOutTracer = Tracer $ liftIO . putStrLn++simpleStdErrTracer :: MonadIO m => Tracer m String+simpleStdErrTracer = Tracer $ liftIO . hPutStrLn stderr++-- | Tracer that discards/ignores all messages. Useful in test suites, if we don't care about logging output+voidTracer :: Applicative m => Tracer m t+voidTracer = Tracer $ const $ pure ()++-- | To avoid having to write those pesky 'liftIO's when changing monads, e.g. when+-- passing the logger into a servant server, we can hide the monad entirely behind an+-- existential, requiring a 'MonadIO' instance.+-- We wrap in newtype instead of just a type synonym, to avoid having to have+-- RankNTypes turned on everywhere.+newtype IOTracer a = IOTracer (forall m. MonadIO m => Tracer m a)++instance Contravariant IOTracer where+ contramap f (IOTracer t) = IOTracer $ contramap f t++instance MonadIO m => TraceWith IOTracer m where+ traceWith (IOTracer (Tracer t)) = t
+ src/Plow/Logging/EnumerableConstructors.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Plow.Logging.EnumerableConstructors (HasEnumerableConstructors (..)) where++import Data.Proxy+import GHC.Generics++class HasEnumerableConstructors1 f where+ listConstructors1 :: f p -> [String]+ allConstructors1 :: Proxy f -> [String]++instance HasEnumerableConstructors1 V1 where+ listConstructors1 _ = []+ allConstructors1 _ = []++instance HasEnumerableConstructors1 U1 where+ listConstructors1 _ = []+ allConstructors1 _ = []++instance (HasEnumerableConstructors a) => HasEnumerableConstructors1 (K1 i a) where+ listConstructors1 (K1 x) = listConstructors x+ allConstructors1 _ = allConstructors (Proxy :: Proxy a)++instance HasEnumerableConstructors1 f => HasEnumerableConstructors1 (D1 c f) where+ listConstructors1 (M1 x) = listConstructors1 x+ allConstructors1 _ = allConstructors1 (Proxy :: Proxy f)++instance (Constructor c, HasEnumerableConstructors1 f) => HasEnumerableConstructors1 (C1 c f) where+ listConstructors1 x@(M1 y) = [conName x] ++ listConstructors1 y+ allConstructors1 _ = [conName (undefined :: C1 c f g)] ++ allConstructors1 (Proxy :: Proxy f)++instance HasEnumerableConstructors1 f => HasEnumerableConstructors1 (S1 c f) where+ listConstructors1 (M1 x) = listConstructors1 x+ allConstructors1 _ = allConstructors1 (Proxy :: Proxy f)++instance (HasEnumerableConstructors1 a, HasEnumerableConstructors1 b) => HasEnumerableConstructors1 (a :+: b) where+ listConstructors1 (L1 x) = listConstructors1 x+ listConstructors1 (R1 x) = listConstructors1 x++ allConstructors1 _ = (allConstructors1 (Proxy :: Proxy a) ++ (allConstructors1 (Proxy :: Proxy b)))++instance (HasEnumerableConstructors1 a, HasEnumerableConstructors1 b) => HasEnumerableConstructors1 (a :*: b) where+ listConstructors1 (a :*: b) = listConstructors1 a ++ listConstructors1 b+ allConstructors1 _ = (allConstructors1 (Proxy :: Proxy a) ++ (allConstructors1 (Proxy :: Proxy b)))++instance HasEnumerableConstructors1 f => HasEnumerableConstructors1 (Rec1 f) where+ listConstructors1 (Rec1 a) = listConstructors1 a+ allConstructors1 _ = allConstructors1 (Proxy :: Proxy f)++class HasEnumerableConstructors a where+ listConstructors :: a -> [String]+ allConstructors :: Proxy a -> [String]+ default listConstructors :: (Generic a, HasEnumerableConstructors1 (Rep a)) => a -> [String]+ listConstructors = listConstructors1 . from++ default allConstructors :: (Generic a, HasEnumerableConstructors1 (Rep a)) => Proxy a -> [String]+ allConstructors _ = allConstructors1 (Proxy :: Proxy (Rep a))++instance {-# OVERLAPPABLE #-} HasEnumerableConstructors a where+ listConstructors _ = []+ allConstructors _ = []++instance HasEnumerableConstructors a => HasEnumerableConstructors [a] where+ listConstructors = concatMap listConstructors+ allConstructors _ = allConstructors (Proxy :: Proxy a)++instance HasEnumerableConstructors a => HasEnumerableConstructors (Maybe a) where+ listConstructors = maybe [] listConstructors+ allConstructors _ = allConstructors (Proxy :: Proxy a)++instance (HasEnumerableConstructors a, HasEnumerableConstructors b) => HasEnumerableConstructors (Either a b) where+ listConstructors = either listConstructors listConstructors+ allConstructors _ = allConstructors (Proxy :: Proxy a) ++ allConstructors (Proxy :: Proxy b)
+ src/Plow/Logging/Message.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Plow.Logging.Message+ ( LogLevel (..),+ LogMessage (..),+ )+where++import Data.Aeson (FromJSON (parseJSON), ToJSON, withText)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Plow.Logging (HasEnumerableConstructors)++-- | Generic log levels+data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text+ deriving (Eq, Ord, Generic, HasEnumerableConstructors, ToJSON)++instance Show LogLevel where+ show LevelDebug = "DEBUG"+ show LevelInfo = "INFO"+ show LevelWarn = "WARN"+ show LevelError = "ERROR"+ show (LevelOther l) = Text.unpack l++instance FromJSON LogLevel where+ parseJSON = withText "LogLevel" $ \case+ "DEBUG" -> pure LevelDebug+ "INFO" -> pure LevelInfo+ "WARN" -> pure LevelWarn+ "ERROR" -> pure LevelError+ other -> pure $ LevelOther other++-- | A log message that allows for a log level to be specified or for the log+-- to be ignored.+data LogMessage a+ = Stdout LogLevel a+ | Ignore+ deriving (Show, Generic, HasEnumerableConstructors)++-- | Concatenates two log messages with a newline, keeping the log level of that has the higher severity+instance (Semigroup String) => Semigroup (LogMessage String) where+ a <> b = case (a, b) of+ (Stdout logLevelA a', Stdout logLevelB b') -> Stdout (max logLevelA logLevelB) (a' <> "\n" <> b')+ (Stdout logLevelA a', Ignore) -> Stdout logLevelA a'+ (Ignore, Stdout logLevelB b') -> Stdout logLevelB b'+ (Ignore, Ignore) -> Ignore
+ src/Plow/Throwing.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE RankNTypes #-}++module Plow.Throwing where++import Data.Functor.Contravariant (Contravariant (..))+import Plow.Logging++newtype Thrower m a = Thrower (forall b. a -> m b)++instance Contravariant (Thrower m) where+ contramap f (Thrower t) = Thrower (t . f)++throwWith :: Thrower m a -> a -> m b+throwWith (Thrower t) a = t a++withTracer :: Monad m => Tracer m a -> Thrower m a -> Thrower m a+withTracer (Tracer tr) (Thrower th) = Thrower $ \m -> tr m >> th m