log-opt (WIP)web

5 files changed, 76 insertions, 3 deletions

diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index b13a1f8..720a5a2 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -8,6 +8,7 @@ module Hsm.Log
   , getLevel
   , logMsg
   , makeLoggerIO
+  , LoggerOptionPrefix
   , runLog
   , runLogs
   ) where
@@ -62,6 +63,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
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
new file mode 100644
index 0000000..a8f7568
--- /dev/null
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -0,0 +1,57 @@
+{-# 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, UInfixE, VarE)
+  , Q
+  , SourceStrictness(NoSourceStrictness)
+  , SourceUnpackedness(NoSourceUnpackedness)
+  , Type(AppT, ConT)
+  , mkName
+  )
+import Options.Applicative (Parser, auto, option)
+
+{-
+
+foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
+                            == f (f (f z x1) x2) x3 ...
+
+z = AppE (VarE 'pure) $ ConE dataName
+f exp next = UInfixE exp (VarE '<*>) next
+
+-}
+makeLoggerOptionParser ::
+     forall ls. KnownSymbols ls
+  => Q [Dec]
+makeLoggerOptionParser =
+  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
+    -- ...
+    dataName = mkName "LoggerOptions"
+    fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix
+    fieldName logger = mkName $ fieldPrefix <> logger
+    fieldBang = Bang NoSourceUnpackedness NoSourceStrictness
+    fieldType = ConT ''Severity
+    field logger = (fieldName logger, fieldBang, fieldType)
+    -- ...
+    parserName = mkName "loggerParser"
+    parserBase = VarE 'pure `AppE` ConE dataName
+    parserApply expr _ = UInfixE expr (VarE '(<*>)) $ VarE 'option `AppE` VarE 'auto
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
diff --git a/hsm-web/Main.hs b/hsm-web/Main.hs
index 9eef1e7..1b35352 100644
--- a/hsm-web/Main.hs
+++ b/hsm-web/Main.hs
@@ -1,7 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 import Effectful (runEff)
 import Hsm.Cam (runCam)
 import Hsm.Log (Severity(Info), runLogs)
+import Hsm.Log.Options (makeLoggerOptionParser)
 import Hsm.Web (runServer, runWeb)
 
+type Loggers = '[ "cam", "libcamera", "scotty", "web"]
+
+$(makeLoggerOptionParser @Loggers)
+
 main :: IO ()
-main = runEff . runLogs @'[ "cam", "libcamera", "scotty", "web"] Info . runCam . runWeb $ runServer
+main = runEff . runLogs @Loggers Info . runCam . runWeb $ runServer
diff --git a/hsm-web/hsm-web.cabal b/hsm-web/hsm-web.cabal
index 89d97e9..42f8d99 100644
--- a/hsm-web/hsm-web.cabal
+++ b/hsm-web/hsm-web.cabal
@@ -35,7 +35,7 @@ executable hsm-web
   default-language: GHC2024
   ghc-options:
     -O2 -threaded -Wall -Werror -Wno-star-is-type -Wunused-packages
-    -fplugin=Effectful.Plugin
+    -ddump-splices -fplugin=Effectful.Plugin
 
   if !arch(x86_64)
     ghc-options: -optl=-mno-fix-cortex-a53-835769