aboutsummaryrefslogtreecommitdiff
path: root/hsm-log/Hsm/Log.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-log/Hsm/Log.hs')
-rw-r--r--hsm-log/Hsm/Log.hs58
1 files changed, 40 insertions, 18 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