Adds CLI parser generator for multiple logger severity settings

3 files changed, 102 insertions, 8 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
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
new file mode 100644
index 0000000..cb44f70
--- /dev/null
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Hsm.Log.Options
+  ( makeLoggerOptionParser
+  ) where
+
+import Data.Proxy (Proxy(Proxy))
+import GHC.TypeLits (symbolVal)
+import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
+import Hsm.Log (LoggerOptionPrefix, Severity)
+import Language.Haskell.TH
+  ( Bang(Bang)
+  , Body(NormalB)
+  , Clause(Clause)
+  , Con(RecC)
+  , Dec(DataD, FunD, SigD)
+  , Exp(AppE, ConE, LitE, ParensE, UInfixE, VarE)
+  , Lit(StringL)
+  , Name
+  , Q
+  , SourceStrictness(NoSourceStrictness)
+  , SourceUnpackedness(NoSourceUnpackedness)
+  , Type(AppT, ConT)
+  , mkName
+  )
+import Options.Applicative (Parser, auto, help, long, metavar, option, showDefault, value)
+
+-- Generates an optparse-applicative parser for multiple logger severity levels
+--
+-- Creates a record type with configurable log levels and a corresponding parser
+-- that accepts command-line arguments like `--log-cam` and `--log-web`.
+--
+-- Example:
+--
+--   $(makeLoggerOptionParser @'[ "cam", "web"] "Options" "parser" 'Info)
+--
+-- Generates:
+-- * Record: `Options { logLevel_cam :: Severity, logLevel_web :: Severity }`
+-- * Parser: `parser :: Parser Options` with default values set to `Info`
+makeLoggerOptionParser ::
+     forall ls. KnownSymbols ls
+  => String
+  -> String
+  -> Name
+  -> Q [Dec]
+makeLoggerOptionParser dataNameString parserNameString defaultSeverity =
+  return
+    [ DataD [] dataName [] Nothing [RecC dataName $ field <$> loggers] []
+    , SigD parserName $ ConT ''Parser `AppT` ConT dataName
+    , FunD parserName [Clause [] (NormalB $ foldl parserApply parserBase loggers) []]
+    ]
+  where
+    loggers = symbolVals @ls
+    -- Record
+    dataName = mkName dataNameString
+    fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix
+    fieldName logger = mkName $ fieldPrefix <> logger
+    fieldBang = Bang NoSourceUnpackedness NoSourceStrictness
+    fieldType = ConT ''Severity
+    field logger = (fieldName logger, fieldBang, fieldType)
+    -- Parser
+    parserName = mkName parserNameString
+    parserBase = VarE 'pure `AppE` ConE dataName
+    parserConfigApply expr = UInfixE expr $ VarE '(<>)
+    parserOptionLong logger = VarE 'long `AppE` LitE (StringL $ "log-" <> logger)
+    parserOptionHelp logger = VarE 'help `AppE` LitE (StringL $ "Sets log level for logger " <> logger)
+    parserOptionShowDefault = VarE 'showDefault
+    parserOptionValue = VarE 'value `AppE` ConE defaultSeverity
+    parserOptionMetavar = VarE 'metavar `AppE` LitE (StringL "LEVEL")
+    parserOptions logger = [parserOptionLong logger, parserOptionHelp logger, parserOptionShowDefault, parserOptionValue, parserOptionMetavar]
+    parserApply expr logger = UInfixE expr (VarE '(<*>)) $ VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger)
diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal
index e8c3972..f20d201 100644
--- a/hsm-log/hsm-log.cabal
+++ b/hsm-log/hsm-log.cabal
@@ -8,12 +8,18 @@ library
     , base
     , effectful-core
     , effectful-plugin
+    , generic-data-functions
     , iso8601-time
+    , optparse-applicative
+    , template-haskell
     , text-ansi
     , time
 
   default-language: GHC2024
-  exposed-modules:  Hsm.Log
+  exposed-modules:
+    Hsm.Log
+    Hsm.Log.Options
+
   ghc-options:
     -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
     -fplugin=Effectful.Plugin