1 files changed, 76 insertions, 0 deletions
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
new file mode 100644
index 0000000..0e00b32
--- /dev/null
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -0,0 +1,76 @@
+{-# 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)