diff --git a/src/Effects/Log.hs b/src/Effects/Log.hs index aee92d7..65c90d8 100644 --- a/src/Effects/Log.hs +++ b/src/Effects/Log.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} module Effects.Log ( @@ -10,17 +12,17 @@ module Effects.Log ( Log, log, LogData (..), + ls, ) where import Colog.Core +import Data.String (IsString (..)) +import Data.String.Conv import Data.Text (Text, justifyLeft) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Builder qualified as T -import Data.Text.Encoding qualified as T -import Data.Text.Lazy.Encoding qualified as LT -import Data.Text.Encoding.Error qualified as T import Effectful import Effectful.Concurrent.QSem import Effectful.Dispatch.Dynamic @@ -30,40 +32,22 @@ import Effects.Time import UnliftIO.Exception (bracket_) import UnliftIO.IO (stderr) import Prelude hiding (log) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB import Terminal -class LogData a where - toLog :: a -> T.Builder - -instance LogData T.Builder where - toLog = id - -instance LogData Text where - toLog = T.fromText - -instance LogData LT.Text where - toLog = T.fromLazyText - -instance LogData String where - toLog = T.fromString - -instance LogData B.ByteString where - toLog = toLog . T.decodeUtf8With T.lenientDecode - -instance LogData LB.ByteString where - toLog = toLog . LT.decodeUtf8With T.lenientDecode +newtype LogData = LogData T.Builder + deriving newtype (IsString) + deriving newtype (Semigroup) + deriving newtype (Monoid) data Log :: Effect where - Log :: Severity -> T.Builder -> Log m () + Log :: Severity -> LogData -> Log m () makeEffect ''Log runLog :: (Time :> es, Concurrent :> es, IOE :> es) => - LogAction IO T.Builder -> + LogAction IO LogData -> Eff (Log : es) a -> Eff es a runLog logger e = do @@ -73,7 +57,7 @@ runLog logger e = do runLogWithQsem :: (Time :> es, Concurrent :> es, IOE :> es) => QSem -> - LogAction IO T.Builder -> + LogAction IO LogData -> Eff (Log : es) a -> Eff es a runLogWithQsem lock logger e = do @@ -83,29 +67,39 @@ runLogWithQsem lock logger e = do Log sev msg -> do lock' <- ask bracket_ (waitQSem lock') (signalQSem lock') $ do - t <- currentTimeB + t <- LogData <$> currentTimeB liftIO $ cmap (addTime t . fmtMessage) logger <& msg `WithSeverity` sev ) e stderrLogger :: (MonadIO m) => - LogAction m T.Builder -stderrLogger = LogAction (liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText) + LogAction m LogData +stderrLogger = + LogAction + ( \(LogData d) -> + liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText $ d + ) -fmtMessage :: WithSeverity T.Builder -> T.Builder -fmtMessage (WithSeverity txt sev) = "[" <> T.fromText (justifyLeft 7 ' ' (colorSev sev)) <> "] - " <> txt +fmtMessage :: WithSeverity LogData -> LogData +fmtMessage (WithSeverity txt sev) = "[" <> ls (justifyLeft 7 ' ' (colorSev sev)) <> "] - " <> txt where colorSev :: Severity -> Text colorSev W = colorNormal Red . tshow $ W colorSev a = tshow a addTime :: - T.Builder -> - T.Builder -> - T.Builder -addTime t msg = (" [" :: T.Builder) <> t <> ("] " :: T.Builder) <> toLog msg + LogData -> + LogData -> + LogData +addTime t msg = " [" <> t <> "] " <> msg --- Helpers -tshow :: Show a => a -> Text +tshow :: (Show a) => a -> Text tshow = T.pack . show + +logStr :: (StringConv a Text) => a -> LogData +logStr t = LogData (T.fromText $ toS t) + +ls :: (StringConv a Text) => a -> LogData +ls = logStr