diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,4 +2,4 @@ [![CircleCI](https://circleci.com/gh/ejconlon/little-logger/tree/master.svg?style=svg)](https://circleci.com/gh/ejconlon/little-logger/tree/master) -Basic logging based on co-log. The difference is that our log action runs in IO, and we expect to use it in any IO-lifting monad. +Basic logging based on co-log. Meant to give you what you need to get started with a single module import. diff --git a/little-logger.cabal b/little-logger.cabal --- a/little-logger.cabal +++ b/little-logger.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 116369e1748442fb579db3e98e1e84bd8587dfe04d6f401f9cd571b200220673 +-- hash: 04ccafa118c9aff9469b3f6df3b75e278af4e203909e6cbc86a24b134f6125d3 name: little-logger -version: 0.1.0 +version: 0.2.0 synopsis: Basic logging based on co-log description: Please see the README on GitHub at category: Logging @@ -36,9 +36,29 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds build-depends: base >=4.12 && <5 - , co-log >=0.4 - , co-log-core >=0.2 - , microlens >=0.4 - , mtl >=2.2 - , text >=1.2 + , co-log >=0.4 && <1 + , co-log-core >=0.2 && <1 + , microlens >=0.4 && <1 + , mtl >=2.2 && <3 + , text >=1.2 && <2 + default-language: Haskell2010 + +test-suite little-logger-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_little_logger + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12 && <5 + , co-log >=0.4 && <1 + , co-log-core >=0.2 && <1 + , little-logger + , microlens >=0.4 && <1 + , mtl >=2.2 && <3 + , tasty >=1.2.3 && <2 + , tasty-hunit >=0.10.0.2 && <1 + , text >=1.2 && <2 default-language: Haskell2010 diff --git a/src/LittleLogger.hs b/src/LittleLogger.hs --- a/src/LittleLogger.hs +++ b/src/LittleLogger.hs @@ -1,14 +1,18 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Rank2Types #-} -{-| Basic logging based on co-log. The difference is that our log action runs in IO, and - we expect to use it in any IO-lifting monad. -} +-- | Basic logging based on co-log. Meant to give you what you need to get started with a single module import. module LittleLogger - ( LogApp (..) - , SimpleLogAction + ( LogAction (..) , HasSimpleLog (..) + , Message + , Msg (..) + , Severity (..) + , SimpleLogAction , WithSimpleLog - , logAppLogAction , defaultSimpleLogAction + , filterActionSeverity , logMsg , logDebug , logError @@ -16,7 +20,7 @@ , logInfo , logWarning , logWithSeverity - , newLogApp + , runWithSimpleLogAction ) where import Colog.Actions (richMessageAction) @@ -25,11 +29,11 @@ import Colog.Message (Message, Msg (..)) import Control.Exception (Exception, displayException) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.Reader (MonadReader (..), ReaderT (..)) import Data.Text (Text) import qualified Data.Text as Text import GHC.Stack (HasCallStack, callStack, withFrozenCallStack) -import Lens.Micro (Lens', lens) +import Lens.Micro (Lens') import Lens.Micro.Extras (view) import Prelude @@ -38,11 +42,17 @@ class HasSimpleLog env where simpleLogL :: Lens' env SimpleLogAction +instance HasSimpleLog SimpleLogAction where + simpleLogL = id + type WithSimpleLog env m = (MonadIO m, MonadReader env m, HasSimpleLog env, HasCallStack) defaultSimpleLogAction :: SimpleLogAction defaultSimpleLogAction = richMessageAction +filterActionSeverity :: Severity -> SimpleLogAction -> SimpleLogAction +filterActionSeverity lim (LogAction f) = LogAction (\msg -> if msgSeverity msg >= lim then f msg else pure ()) + logMsg :: WithSimpleLog env m => Message -> m () logMsg msg = do env <- ask @@ -67,13 +77,7 @@ logException :: (WithSimpleLog env m, Exception e) => e -> m () logException = withFrozenCallStack (logError . Text.pack . displayException) -newtype LogApp = LogApp { _logAppLogAction :: SimpleLogAction } - -logAppLogAction :: Lens' LogApp SimpleLogAction -logAppLogAction = lens _logAppLogAction (const LogApp) - -instance HasSimpleLog LogApp where - simpleLogL = logAppLogAction - -newLogApp :: LogApp -newLogApp = LogApp defaultSimpleLogAction +-- | Usually 'm' will be some kind of 'Reader' monad. In the case where you don't care what it +-- is and you only need to do logging and IO, you can use this. +runWithSimpleLogAction :: SimpleLogAction -> (forall env m. WithSimpleLog env m => m a) -> IO a +runWithSimpleLogAction = flip runReaderT diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +module Main (main) where + +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Text (Text) +import LittleLogger (LogAction (LogAction), Msg (msgSeverity, msgText), Severity (..), SimpleLogAction, WithSimpleLog, + filterActionSeverity, logDebug, logError, logInfo, logWarning, runWithSimpleLogAction) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +emitLogs :: WithSimpleLog env m => m () +emitLogs = do + logDebug "debug" + logInfo "info" + logWarning "warning" + logError "error" + +refAction :: IORef [(Severity, Text)] -> SimpleLogAction +refAction ref = LogAction (\msg -> modifyIORef' ref (++ [(msgSeverity msg, msgText msg)])) + +runWithRefAction :: (SimpleLogAction -> SimpleLogAction) -> (forall env m. WithSimpleLog env m => m ()) -> IO [(Severity, Text)] +runWithRefAction f m = do + ref <- newIORef [] + let action = f (refAction ref) + runWithSimpleLogAction action m + readIORef ref + +expectedFiltered :: [(Severity, Text)] +expectedFiltered = + [ (Warning, "warning") + , (Error, "error") + ] + +expectedUnfiltered :: [(Severity, Text)] +expectedUnfiltered = + [ (Debug, "debug") + , (Info, "info") + ] ++ expectedFiltered + +testUnfiltered :: TestTree +testUnfiltered = testCase "Unfiltered" $ do + actual <- runWithRefAction id emitLogs + actual @?= expectedUnfiltered + +testFiltered :: TestTree +testFiltered = testCase "Filtered" $ do + actual <- runWithRefAction (filterActionSeverity Warning) emitLogs + actual @?= expectedFiltered + +main :: IO () +main = defaultMain $ testGroup "LittleLogger" $ + [ testUnfiltered + , testFiltered + ]