1 files changed, 81 insertions, 32 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