diff options
Diffstat (limited to 'hsm-log/Hsm/Log.hs')
| -rw-r--r-- | hsm-log/Hsm/Log.hs | 30 |
1 files changed, 23 insertions, 7 deletions
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs index b13a1f8..a0cf49c 100644 --- a/hsm-log/Hsm/Log.hs +++ b/hsm-log/Hsm/Log.hs @@ -8,8 +8,11 @@ module Hsm.Log , getLevel , logMsg , makeLoggerIO + , LoggerOptionPrefix , runLog + , runLogOpt , runLogs + , runLogsOpt ) where import Control.Monad (when) @@ -21,14 +24,15 @@ import Data.Time.ISO8601 (formatISO8601Millis) import Effectful (Dispatch(Static), DispatchOf, Eff, Effect, IOE, (:>)) import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_) import GHC.Conc.Sync (fromThreadId, myThreadId) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import GHC.Records (HasField, getField) +import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal) import String.ANSI (blue, green, red, white) data Severity = Attention | Info | Trace - deriving (Enum, Eq, Ord) + deriving (Enum, Eq, Ord, Read, Show) coloredShow :: Severity -> String coloredShow Attention = red "ATTENTION" @@ -62,6 +66,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 @@ -69,14 +75,24 @@ runLog :: -> Eff es a runLog = evalStaticRep . Log -class Logs (ds :: [Symbol]) (es :: [Effect]) where +runLogOpt :: + forall d f o es a. (AppendSymbol LoggerOptionPrefix 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 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 ('[] :: [Symbol]) (es :: [Effect]) where +instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where type Insert '[] es = es - runLogs _ = id + runLogs = const id + runLogsOpt = const id -instance (IOE :> Insert ds es, KnownSymbol d, Logs ds es) => Logs (d : ds :: [Symbol]) (es :: [Effect]) where +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]) where type Insert (d : ds) es = Log d : Insert ds es - runLogs level = runLogs @ds level . runLog @d level + runLogs level = runLogs @o @ds level . runLog @d level + runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts |