diff options
Diffstat (limited to 'hsm-log/Hsm')
| -rw-r--r-- | hsm-log/Hsm/Log.hs | 28 | ||||
| -rw-r--r-- | hsm-log/Hsm/Log/Options.hs | 4 |
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 |