aboutsummaryrefslogtreecommitdiff
path: root/hsm-log/Hsm
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-log/Hsm')
-rw-r--r--hsm-log/Hsm/Log.hs58
-rw-r--r--hsm-log/Hsm/Log/Options.hs38
2 files changed, 61 insertions, 35 deletions
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index a0cf49c..99e5b7c 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Hsm.Log
- ( Severity(Attention, Info, Trace)
+ ( Severity (Attention, Info, Trace)
, Log
, getLevel
, logMsg
@@ -13,16 +13,25 @@ module Hsm.Log
, runLogOpt
, runLogs
, runLogsOpt
- ) where
+ )
+where
import Control.Monad (when)
import Data.Function (applyWhen)
import Data.List (intercalate)
-import Data.Proxy (Proxy(Proxy))
+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, unEff, unsafeEff, unsafeEff_)
+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)
@@ -43,14 +52,15 @@ 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
getLevel :: Log d :> es => Eff es Severity
getLevel = getStaticRep >>= \(Log level) -> return level
-logMsg ::
- forall d es. (KnownSymbol d, Log d :> es)
+logMsg
+ :: forall d es
+ . (KnownSymbol d, Log d :> es)
=> Severity
-> String
-> Eff es ()
@@ -59,24 +69,33 @@ logMsg severity message = do
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)
+ 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
type LoggerOptionPrefix = "logLevel_"
-runLog ::
- forall d es a. IOE :> es
+runLog
+ :: forall d es a
+ . IOE :> es
=> Severity
-> Eff (Log d : es) a
-> Eff es a
runLog = evalStaticRep . Log
-runLogOpt ::
- forall d f o es a. (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
+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
@@ -92,7 +111,10 @@ instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
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]) 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 @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
index cb44f70..0e00b32 100644
--- a/hsm-log/Hsm/Log/Options.hs
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -3,25 +3,26 @@
module Hsm.Log.Options
( makeLoggerOptionParser
- ) where
+ )
+where
-import Data.Proxy (Proxy(Proxy))
+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)
+ ( 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)
+ , SourceStrictness (NoSourceStrictness)
+ , SourceUnpackedness (NoSourceUnpackedness)
+ , Type (AppT, ConT)
, mkName
)
import Options.Applicative (Parser, auto, help, long, metavar, option, showDefault, value)
@@ -36,10 +37,11 @@ import Options.Applicative (Parser, auto, help, long, metavar, option, showDefau
-- $(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
+-- - 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
@@ -69,4 +71,6 @@ makeLoggerOptionParser dataNameString parserNameString defaultSeverity =
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)
+ parserApply expr logger =
+ UInfixE expr (VarE '(<*>)) $
+ VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger)
powered by cgit v1.2.1, back to main portfolio site