diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +# stack uses this directory for build artifacts +/.stack-work/ + +# Made by 'hasktags --ctags .' +tags diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +1.0.0 (2026-08-27) + + * Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,15 @@ +Copyright (c) 2026, Dino Morelli + +Permission to use, copy, modify, and/or distribute this software +for any purpose with or without fee is hereby granted, provided +that the above copyright notice and this permission notice appear +in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA +OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,37 @@ +# hslogger-colorfmt + + +## Synopsis + +Custom hslogger formatters implementing color output + + +## Description + +This library adds some custom log formatters implementing color output. We have +also added code to pad the Priority strings in log messages if desired. + +Here's a screenshot of output from [some sample code](src/examples/Main.hs): + +
+ +For examining and choosing colors, there are many scripts out there for +displaying 256 color samples in terminals. Here's a particularly +[nice one](https://gist.github.com/HaleTom/89ffe32783f89f403bba96bd7bcd1263). + + +## Getting source + +Source code is available here: [hslogger-colorfmt](https://codeberg.org/dinofp/hslogger-colorfmt) + +Handy command to generate Haddock docs during development if using stack. This +constrains doc generation to modules in the library: + + $ stack haddock --haddock --no-haddock-deps + + +## Contact + +Dino Morelli + +[![Made by a human badge](doc/MadeByAHuman_01.png)](https://ko-fi.com/s/4662b19f61) This work is hand-crafted with no LLM/AI involved diff --git a/hslogger-colorfmt.cabal b/hslogger-colorfmt.cabal new file mode 100644 --- /dev/null +++ b/hslogger-colorfmt.cabal @@ -0,0 +1,60 @@ +cabal-version: 2.2 + +name: hslogger-colorfmt +version: 1.0.0 +synopsis: Custom hslogger formatters implementing color output +description: + This library adds some custom log formatters implementing color output. We + have also added code to pad the Priority strings in log messages if desired. +author: Dino Morelli +maintainer: dino@ui3.info +copyright: 2026 Dino Morelli +category: Interfaces, Logging +license: ISC +license-file: LICENSE +build-type: Simple +extra-source-files: + .gitignore + README.md + stack.yaml +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://codeberg.org/dinofp/hslogger-colorfmt + +common lang + default-language: Haskell2010 + ghc-options: + -fwarn-tabs + -Wall + -Wcompat + -Wderiving-typeable + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + build-depends: + base >=3 && <5 + , hslogger >= 1.3.1.2 && < 2 + +library + import: lang + exposed-modules: + System.Log.Color + System.Log.Color.Formatter + System.Log.Util + hs-source-dirs: + src/lib + build-depends: + ansi-terminal >= 1.1 && < 2 + , time >= 1.12.2 && < 2 + +executable hslogger-colorfmt-example + import: lang + main-is: Main.hs + hs-source-dirs: + src/examples + build-depends: + hslogger-colorfmt diff --git a/src/examples/Main.hs b/src/examples/Main.hs new file mode 100644 --- /dev/null +++ b/src/examples/Main.hs @@ -0,0 +1,52 @@ +import System.IO (stdout) + +-- from hslogger +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (streamHandler) +import System.Log.Logger + +-- from hslogger-colorfmt +import System.Log.Color +import System.Log.Color.Formatter +import System.Log.Util + + +n :: String +n = "mylogger" + +msgFormat :: String +msgFormat = "$time $loggername $padPrio: $msg" + + +initLogging :: String -> Maybe Priority -> IO () +initLogging loggerName mLogPriority = do + -- Removes the root logger's default handler that writes every + -- message to stderr! + updateGlobalLogger rootLoggerName removeHandler + + case mLogPriority of + Nothing -> pure () + (Just logPriority) -> do + updateGlobalLogger loggerName . addHandler + . flip setFormatter (colorLogFormatter colors16 msgFormat) + =<< streamHandler stdout DEBUG + + updateGlobalLogger loggerName $ setLevel logPriority + + +main :: IO () +main = do + putStrLn "------------------------------------------" + -- Example of completely turning off logging + alertM n "This ALERT message is visible because of hslogger's default settings" + alertM n "which is WARNING or higher and output to stderr." + alertM n "We almost never want this. Getting rid of it:\n" + putStrLn " initLogging n Nothing\n" + initLogging n Nothing + emergencyM n "This message should never be shown" + + putStrLn "------------------------------------------" + putStrLn "Example of color logging with padded Priority:\n" + putStrLn " initLogging n $ Just DEBUG\n" + initLogging n $ Just DEBUG + logTest n diff --git a/src/lib/System/Log/Color.hs b/src/lib/System/Log/Color.hs new file mode 100644 --- /dev/null +++ b/src/lib/System/Log/Color.hs @@ -0,0 +1,92 @@ +{-| + Module containing color definitions, mappings between @Priority@ and color, + and code to apply color to the terminal. +-} +module System.Log.Color + ( ColorMap + + , colorize + + , black, red, green, yellow, blue, magenta, cyan, white + , grey, bred, bgreen , byellow, bblue, bmagenta, bcyan, bwhite + , colors16, colors256, noColor + ) + where + +import Data.List (find) +import Data.Word (Word8) +import System.Console.ANSI (ConsoleLayer (Foreground), SGR (..), setSGRCode) +import System.Log.Logger (Priority (..)) + + +colorize :: ColorMap -> Priority -> String -> String +colorize colorMap prio str = case priorityColor of + (Just (swapColors, color)) -> + setSGRCode [SetPaletteColor Foreground color] + <> setSGRCode [SetSwapForegroundBackground swapColors] + <> str + <> setSGRCode [Reset] + Nothing -> str + + where + priorityColor = snd <$> find ((== prio) . fst) colorMap + + +-- | These correspond to the basic 16 ANSI term color values +black, red, green, yellow, blue, magenta, cyan, white, grey, bred, bgreen, + byellow, bblue, bmagenta, bcyan, bwhite :: Word8 +black = 0 +red = 1 +green = 2 +yellow = 3 +blue = 4 +magenta = 5 +cyan = 6 +white = 7 +grey = 8 +bred = 9 +bgreen = 10 +byellow = 11 +bblue = 12 +bmagenta = 13 +bcyan = 14 +bwhite = 15 + + +-- | This type maps a logging Priority to a pair indicating if the output +-- should be inverted (foreground and background swapped) and the color value +-- as a @Word8@ (an index into the 256 color palette) +type ColorMap = [(Priority, (Bool, Word8))] + + +-- | Use this @ColorMap@ to disable color entirely +noColor :: ColorMap +noColor = [] + + +-- | Basic colors. Good when the term doesn't support 256. +colors16 :: ColorMap +colors16 = + [ (DEBUG , (False, bcyan)) + , (INFO , (False, bgreen)) + , (NOTICE , (False, bwhite)) + , (WARNING , (False, byellow)) + , (ERROR , (False, bred)) + , (CRITICAL , (False, magenta)) + , (ALERT , (False, bblue)) + , (EMERGENCY, (True, bred)) + ] + + +-- | Some decent colors +colors256 :: ColorMap +colors256 = + [ (DEBUG , (False, 75)) -- Easier-to-read blue + , (INFO , (False, 156)) -- Minty green + , (NOTICE , (False, bwhite)) -- White + , (WARNING , (False, byellow)) -- Bright yellow + , (ERROR , (False, bred)) -- Bright red + , (CRITICAL , (False, 161)) -- Dull red + , (ALERT , (False, 206)) -- Brighter magenta + , (EMERGENCY, (True, bred)) -- Inverted bright red + ] diff --git a/src/lib/System/Log/Color/Formatter.hs b/src/lib/System/Log/Color/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/lib/System/Log/Color/Formatter.hs @@ -0,0 +1,70 @@ +{-| +This module implements custom formatters, @colorLogFormatter@ and +@tfColorLogFormatter@, that behave much like @simpleLogFormatter@ and +@tfLogFormatter@ but optionally colors the messages and adds a +new field, @$padPrio@, to format all Priority values to the same width. + + * @$padPrio@ - The padded priority level of the message + +The stock hslogger fields are also still available + + * @$msg@ - The actual log message + * @$loggername@ - The name of the logger + * @$prio@ - The priority level of the message + * @$tid@ - The thread ID + * @$pid@ - Process ID + * @$time@ - The current local time + * @$utcTime@ - The current UTC time + +Note: I also took the liberty of changing the default date/time formatter to +@"%F %X %Z"@ which sorts nicely. + + +Use this like you would any other @hslogger@ @Formatter@ + + @setFormatter someHandler (colorLogFormatter colors16 "$time $loggername $padPrio: $msg")@ +-} +module System.Log.Color.Formatter + ( colorLogFormatter + , tfColorLogFormatter + ) + where + +import Data.Time (formatTime, getCurrentTime, getZonedTime) +import Data.Time.Format (defaultTimeLocale) +import System.Log.Formatter (LogFormatter, varFormatter) +import System.Log.Logger (Priority (..)) + +import System.Log.Color (ColorMap, colorize) + + +-- | This function behaves much like @simpleLogFormatter@ but optionally +-- colors the messages and adds a new field, @$padPrio@, to format all +-- Priority values to the same width. +colorLogFormatter :: ColorMap -> String -> LogFormatter a +colorLogFormatter colorMap msgFormat = + tfColorLogFormatter colorMap msgFormat "%F %X %Z" + + +-- | This function behaves much like @tfLogFormatter@ but optionally +-- colors the messages and adds a new field, @$padPrio@, to format all +-- Priority values to the same width. +tfColorLogFormatter :: ColorMap -> String -> String -> LogFormatter a +tfColorLogFormatter colorMap msgFormat timeFormat h (prio, msg) loggerName = + colorize colorMap prio <$> varFormatter + [ ("padPrio", pure $ showPadded prio) + , ("time", formatTime defaultTimeLocale timeFormat <$> getZonedTime) + , ("utcTime", formatTime defaultTimeLocale timeFormat <$> getCurrentTime) + ] + msgFormat h (prio, msg) loggerName + + +showPadded :: Priority -> String +showPadded DEBUG = "DEBUG " +showPadded INFO = "INFO " +showPadded NOTICE = "NOTICE " +showPadded WARNING = "WARNING " +showPadded ERROR = "ERROR " +showPadded CRITICAL = "CRITICAL " +showPadded ALERT = "ALERT " +showPadded EMERGENCY = "EMERGENCY" diff --git a/src/lib/System/Log/Util.hs b/src/lib/System/Log/Util.hs new file mode 100644 --- /dev/null +++ b/src/lib/System/Log/Util.hs @@ -0,0 +1,19 @@ +module System.Log.Util + ( logTest + ) + where + +import System.Log.Logger + + +-- | Test function to generate every kind of log message +logTest :: String -> IO () +logTest loggerName = do + debugM loggerName "log test message DEBUG 1 of 8" + infoM loggerName "log test message INFO 2 of 8" + noticeM loggerName "log test message NOTICE 3 of 8" + warningM loggerName "log test message WARNING 4 of 8" + errorM loggerName "log test message ERROR 5 of 8" + criticalM loggerName "log test message CRITICAL 6 of 8" + alertM loggerName "log test message ALERT 7 of 8" + emergencyM loggerName "log test message EMERGENCY 8 of 8" diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,68 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/configure/yaml/ + +# A 'specific' Stackage snapshot or a compiler version. +# A snapshot dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# snapshot: lts-24.24 +# snapshot: nightly-2025-12-20 +# snapshot: ghc-9.10.3 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# snapshot: ./custom-snapshot.yaml +# snapshot: https://example.com/snapshots/2024-01-01.yaml +# snapshot: +# url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/36.yaml +snapshot: lts-24.11 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the snapshot. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for project packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=3.9" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor