log.hs

#!/usr/bin/env runghc

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GHC2024 #-}

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Main (main) where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Reader (ReaderT (..), ask, local, runReaderT)
import Data.Bifunctor (first)
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Prelude hiding (log)
import System.IO (hPutStrLn, stderr)

type Scope = [String]

type Message = String

type Attributes = [(String, String)]

type Logger = Scope -> Message -> Attributes -> IO ()

stderrLogger :: Logger
stderrLogger scope message attributes =
  hPutStrLn stderr . concat . catMaybes $
    [ showScope scope
    , Just message
    , showAttributes attributes
    ]
  where
  showScope :: Scope -> Maybe String
  showScope = \case
    [] -> Nothing
    ss -> Just ("[" <> foldr (\s r -> concat [r, "/", s]) "" (reverse ss) <> "] ")

  showAttributes :: Attributes -> Maybe String
  showAttributes = \case
    [] -> Nothing
    as -> Just (" [" <> intercalate "," [k <> "=" <> v | (k, v) <- as] <> "]")

newtype AppM a = AppM (ReaderT (Scope, Logger) IO a)
  deriving newtype (Functor, Applicative, Monad, MonadIO)

runAppM :: Logger -> AppM a -> IO a
runAppM logger (AppM readerT) = runReaderT readerT ([], logger)

scope :: String -> AppM a -> AppM a
scope name (AppM readerT) = AppM (local (first (name :)) readerT)

log :: String -> [(String, String)] -> AppM ()
log message attributes = do
  (scope, logger) <- AppM ask
  liftIO $ logger scope message attributes

main :: IO ()
main = do
  runAppM stderrLogger do
    log "first" []
    log "no scope w/o attrs" []
    log "no scope w/ attrs" [("n", "0")]
    scope "foo" do
      log "first message in foo scope" [("n", "1"), ("answer", "42")]
      log "2nd in foo scope" [("n", "2")]
      scope "bar" do
        log "lorem ipsum" [("n", "3")]
        scope "360noscope" do
          log "goodbye" [("n", "4")]

{-

$ ./log.hs
first
no scope w/o attrs
no scope w/ attrs [n=0]
[/foo] first message in foo scope [n=1,answer=42]
[/foo] 2nd in foo scope [n=2]
[/bar/foo] lorem ipsum [n=3]
[/360noscope/bar/foo] goodbye [n=4]

-}