diff options
| author | Paul Oliver <contact@pauloliver.dev> | 2025-09-03 21:14:13 +0000 |
|---|---|---|
| committer | Paul Oliver <contact@pauloliver.dev> | 2025-09-05 00:32:06 +0000 |
| commit | cd217ecf5bc7a04c9d594876f753916a098bf3b7 (patch) | |
| tree | 94879e49053523031f5d3519bad54f12282719c5 /hsm-log/Hsm/Log.hs | |
| parent | 9a25a505a77a56e9dfa277618d01d33deb19a2e1 (diff) | |
Adds CLI parser generator for multiple logger severity settings
Diffstat (limited to 'hsm-log/Hsm/Log.hs')
| -rw-r--r-- | hsm-log/Hsm/Log.hs | 30 |
1 files changed, 23 insertions, 7 deletions
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs index b13a1f8..a0cf49c 100644 --- a/hsm-log/Hsm/Log.hs +++ b/hsm-log/Hsm/Log.hs @@ -8,8 +8,11 @@ module Hsm.Log , getLevel , logMsg , makeLoggerIO + , LoggerOptionPrefix , runLog + , runLogOpt , runLogs + , runLogsOpt ) where import Control.Monad (when) @@ -21,14 +24,15 @@ import Data.Time.ISO8601 (formatISO8601Millis) import Effectful (Dispatch(Static), DispatchOf, Eff, Effect, IOE, (:>)) import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_) import GHC.Conc.Sync (fromThreadId, myThreadId) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import GHC.Records (HasField, getField) +import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal) import String.ANSI (blue, green, red, white) data Severity = Attention | Info | Trace - deriving (Enum, Eq, Ord) + deriving (Enum, Eq, Ord, Read, Show) coloredShow :: Severity -> String coloredShow Attention = red "ATTENTION" @@ -62,6 +66,8 @@ makeLoggerIO :: => Eff es (Severity -> String -> IO ()) makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env +type LoggerOptionPrefix = "logLevel_" + runLog :: forall d es a. IOE :> es => Severity @@ -69,14 +75,24 @@ runLog :: -> Eff es a runLog = evalStaticRep . Log -class Logs (ds :: [Symbol]) (es :: [Effect]) where +runLogOpt :: + forall d f o es a. (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es) + => o + -> Eff (Log d : es) a + -> Eff es a +runLogOpt = runLog . getField @f + +class Logs (o :: *) (ds :: [Symbol]) (es :: [Effect]) where type Insert ds es :: [Effect] runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a + runLogsOpt :: o -> Eff (Insert ds es) a -> Eff es a -instance Logs ('[] :: [Symbol]) (es :: [Effect]) where +instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where type Insert '[] es = es - runLogs _ = id + runLogs = const id + runLogsOpt = const id -instance (IOE :> Insert ds es, KnownSymbol d, Logs ds es) => Logs (d : ds :: [Symbol]) (es :: [Effect]) where +instance (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, Logs o ds es) => Logs (o :: *) (d : ds :: [Symbol]) (es :: [Effect]) where type Insert (d : ds) es = Log d : Insert ds es - runLogs level = runLogs @ds level . runLog @d level + runLogs level = runLogs @o @ds level . runLog @d level + runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts |