aboutsummaryrefslogtreecommitdiff
path: root/hsm-log
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-log')
-rw-r--r--hsm-log/Hsm/Log.hs113
-rw-r--r--hsm-log/Hsm/Log/Options.hs76
-rw-r--r--hsm-log/hsm-log.cabal9
3 files changed, 164 insertions, 34 deletions
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index 3c25501..99e5b7c 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -3,69 +3,118 @@
{-# LANGUAGE UndecidableInstances #-}
module Hsm.Log
- ( Severity(Attention, Info, Trace)
+ ( Severity (Attention, Info, Trace)
, Log
- , getLoggerIO
+ , getLevel
, logMsg
+ , makeLoggerIO
+ , LoggerOptionPrefix
, runLog
- ) where
+ , runLogOpt
+ , runLogs
+ , runLogsOpt
+ )
+where
import Control.Monad (when)
import Data.Function (applyWhen)
-import Data.Proxy (Proxy(Proxy))
+import Data.List (intercalate)
+import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock (getCurrentTime)
import Data.Time.ISO8601 (formatISO8601Millis)
-import Effectful (Dispatch(Static), DispatchOf, Eff, Effect, IOE, (:>))
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
-import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
-import GHC.TypeLits.Printf (printf)
-import String.ANSI (red)
+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.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, Show)
+ deriving (Enum, Eq, Ord, Read, Show)
+
+coloredShow :: Severity -> String
+coloredShow Attention = red "ATTENTION"
+coloredShow Info = green "INFO"
+coloredShow Trace = blue "TRACE"
data Log (d :: Symbol) (a :: * -> *) (b :: *)
type instance DispatchOf (Log d) = Static WithSideEffects
-newtype instance StaticRep (Log d) =
- Log Severity
+newtype instance StaticRep (Log d)
+ = Log Severity
-getLoggerIO ::
- forall d es. (KnownSymbol d, Log d :> es)
- => Eff es (Severity -> String -> IO ())
-getLoggerIO = do
- Log level <- getStaticRep
- return $ \severity message ->
- when (severity <= level) $ do
- time <- formatISO8601Millis <$> getCurrentTime
- putStrLn . applyWhen (severity == Attention) red $ printf "%s %s [%s] %s" time (symbolVal $ Proxy @d) (show severity) message
-
-logMsg ::
- forall d es. (KnownSymbol d, Log d :> es)
+getLevel :: Log d :> es => Eff es Severity
+getLevel = getStaticRep >>= \(Log level) -> return level
+
+logMsg
+ :: forall d es
+ . (KnownSymbol d, Log d :> es)
=> Severity
-> String
-> Eff es ()
-logMsg severity message = getLoggerIO >>= \loggerIO -> unsafeEff_ $ loggerIO severity message
+logMsg severity message = do
+ level <- getLevel
+ when (severity <= level) . unsafeEff_ $ do
+ time <- formatISO8601Millis <$> getCurrentTime
+ domainAndThreadId <- myThreadId >>= \tid -> return . white $ symbolVal (Proxy @d) <> ":" <> show (fromThreadId tid)
+ putStrLn $
+ unwords
+ [ time
+ , domainAndThreadId
+ , coloredShow severity
+ , applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message
+ ]
+
+makeLoggerIO
+ :: forall d es
+ . (KnownSymbol d, Log d :> es)
+ => Eff es (Severity -> String -> IO ())
+makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env
-runLog ::
- forall d es a. IOE :> es
+type LoggerOptionPrefix = "logLevel_"
+
+runLog
+ :: forall d es a
+ . IOE :> es
=> Severity
-> Eff (Log d : es) a
-> 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
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
new file mode 100644
index 0000000..0e00b32
--- /dev/null
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -0,0 +1,76 @@
+{-# 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)
diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal
index 7aab0de..f20d201 100644
--- a/hsm-log/hsm-log.cabal
+++ b/hsm-log/hsm-log.cabal
@@ -8,13 +8,18 @@ library
, base
, effectful-core
, effectful-plugin
+ , generic-data-functions
, iso8601-time
+ , optparse-applicative
+ , template-haskell
, text-ansi
, time
- , typelits-printf
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
powered by cgit v1.2.1, back to main portfolio site