1 files changed, 72 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..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)