Adds `Logs` constraint combinatorreimplement_drive

2 files changed, 22 insertions, 10 deletions

diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index 99e5b7c..bd8c73f 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -5,10 +5,11 @@
 module Hsm.Log
   ( Severity (Attention, Info, Trace)
   , Log
+  , Logs
+  , LogOptionPrefix
   , getLevel
   , logMsg
   , makeLoggerIO
-  , LoggerOptionPrefix
   , runLog
   , runLogOpt
   , runLogs
@@ -18,6 +19,7 @@ where
 
 import Control.Monad (when)
 import Data.Function (applyWhen)
+import Data.Kind (Constraint)
 import Data.List (intercalate)
 import Data.Proxy (Proxy (Proxy))
 import Data.Time.Clock (getCurrentTime)
@@ -55,6 +57,18 @@ type instance DispatchOf (Log d) = Static WithSideEffects
 newtype instance StaticRep (Log d)
   = Log Severity
 
+-- Constraint combinator for multiple logger effects
+-- Simplifies effect constraints for functions requiring multiple loggers.
+--
+-- Example:
+-- >>> :kind! Logs '["log1", "log2"] es
+-- (Log "log1" :> es, Log "log2" :> es)
+type family Logs ls es :: Constraint where
+  Logs '[] es = ()
+  Logs (l : ls) es = (Log l :> es, Logs ls es)
+
+type LogOptionPrefix = "logLevel_"
+
 getLevel :: Log d :> es => Eff es Severity
 getLevel = getStaticRep >>= \(Log level) -> return level
 
@@ -83,8 +97,6 @@ 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
@@ -95,25 +107,25 @@ runLog = evalStaticRep . Log
 
 runLogOpt
   :: forall d f o es a
-   . (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
+   . (AppendSymbol LogOptionPrefix 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
+class LogsClass (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 (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
+instance LogsClass (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
   type Insert '[] es = es
   runLogs = const id
   runLogsOpt = const id
 
 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])
+  (AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, LogsClass o ds es)
+  => LogsClass (o :: *) (d : ds :: [Symbol]) (es :: [Effect])
   where
   type Insert (d : ds) es = Log d : Insert ds es
   runLogs level = runLogs @o @ds level . runLog @d level
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
index 0e00b32..877aa4b 100644
--- a/hsm-log/Hsm/Log/Options.hs
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -9,7 +9,7 @@ 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 Hsm.Log (LogOptionPrefix, Severity)
 import Language.Haskell.TH
   ( Bang (Bang)
   , Body (NormalB)
@@ -56,7 +56,7 @@ makeLoggerOptionParser dataNameString parserNameString defaultSeverity =
     loggers = symbolVals @ls
     -- Record
     dataName = mkName dataNameString
-    fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix
+    fieldPrefix = symbolVal $ Proxy @LogOptionPrefix
     fieldName logger = mkName $ fieldPrefix <> logger
     fieldBang = Bang NoSourceUnpackedness NoSourceStrictness
     fieldType = ConT ''Severity