Polishes `hsm-log` even more

2 files changed, 18 insertions, 32 deletions

diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index 570b19a..b13a1f8 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -6,9 +6,8 @@ module Hsm.Log
   ( Severity(Attention, Info, Trace)
   , Log
   , getLevel
-  , makeLoggerIO
   , logMsg
-  , logBlock
+  , makeLoggerIO
   , runLog
   , runLogs
   ) where
@@ -20,7 +19,7 @@ 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 Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_)
 import GHC.Conc.Sync (fromThreadId, myThreadId)
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import String.ANSI (blue, green, red, white)
@@ -31,6 +30,11 @@ data Severity
   | Trace
   deriving (Enum, Eq, Ord)
 
+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
@@ -41,40 +45,22 @@ newtype instance StaticRep (Log d) =
 getLevel :: Log d :> es => Eff es Severity
 getLevel = getStaticRep >>= \(Log level) -> return level
 
-makeLoggerIO ::
-     forall d es. (KnownSymbol d, Log d :> es)
-  => Eff es (Severity -> String -> IO ())
-makeLoggerIO = loggerIO <$> getLevel
-  where
-    loggerIO level severity message =
-      when (severity <= level) $ do
-        time <- formatISO8601Millis <$> getCurrentTime
-        threadId <- show . fromThreadId <$> myThreadId
-        putStrLn $ unwords [time, fmtDomainAndThreadId threadId, fmtSeverity, fmtMessage]
-      where
-        fmtDomainAndThreadId threadId = white $ symbolVal (Proxy @d) <> ":" <> threadId
-        fmtSeverity =
-          case severity of
-            Attention -> red "ATTENTION"
-            Info -> green "INFO"
-            Trace -> blue "TRACE"
-        fmtMessage = applyWhen (severity == Attention) red message
-
 logMsg ::
      forall d es. (KnownSymbol d, Log d :> es)
   => Severity
   -> String
   -> Eff es ()
-logMsg severity message = makeLoggerIO >>= \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]
 
-logBlock ::
+makeLoggerIO ::
      forall d es. (KnownSymbol d, Log d :> es)
-  => Severity
-  -> String
-  -> Eff es ()
-logBlock severity message = logMsg severity $ separator <> intercalate separator (lines message)
-  where
-    separator = "\n ... "
+  => Eff es (Severity -> String -> IO ())
+makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env
 
 runLog ::
      forall d es a. IOE :> es
diff --git a/hsm-repl/Hsm/Repl.hs b/hsm-repl/Hsm/Repl.hs
index 45a2cf2..6bcf39d 100644
--- a/hsm-repl/Hsm/Repl.hs
+++ b/hsm-repl/Hsm/Repl.hs
@@ -13,7 +13,7 @@ import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalS
 import Effectful.Exception (bracket)
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
-import Hsm.Log (Log, Severity(Attention, Info, Trace), logBlock, logMsg)
+import Hsm.Log (Log, Severity(Attention, Info, Trace), logMsg)
 import Language.Haskell.Interpreter (GhcError(errMsg), InterpreterError(WontCompile), as, interpret, runInterpreter, setImports)
 import String.ANSI (blue)
 import System.Console.Haskeline (defaultSettings, getInputLine, handleInterrupt, withInterrupt)
@@ -46,7 +46,7 @@ repl = query >>= maybe (return Nothing) parse
           logMsg Trace $ "Parsed value: " <> show value
           return $ Just value
         Left (WontCompile errors) -> do
-          forM_ errors $ logBlock Attention . errMsg
+          forM_ errors $ logMsg Attention . errMsg
           repl
         Left err -> do
           logMsg Attention $ show err