99 lines
2.2 KiB
Haskell
99 lines
2.2 KiB
Haskell
{-# LANGUAGE PatternSynonyms #-}
|
|
|
|
module Effects.Log (
|
|
Severity (.., I, D, W, E),
|
|
runLog,
|
|
runLogWithQsem,
|
|
stderrLogger,
|
|
fmtMessage,
|
|
addTime,
|
|
Log,
|
|
log,
|
|
LogData (..),
|
|
) where
|
|
|
|
import Colog.Core
|
|
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 Effectful
|
|
import Effectful.Concurrent.QSem
|
|
import Effectful.Dispatch.Dynamic
|
|
import Effectful.Reader.Static
|
|
import Effectful.TH
|
|
import Effects.Time
|
|
import UnliftIO.Exception (bracket_)
|
|
import UnliftIO.IO (stderr)
|
|
import Prelude hiding (log)
|
|
|
|
import Terminal
|
|
|
|
class Monoid a => LogData a where
|
|
toLog :: a -> T.Builder
|
|
|
|
instance LogData T.Builder where
|
|
toLog = id
|
|
|
|
instance LogData Text where
|
|
toLog = T.fromText
|
|
|
|
instance LogData String where
|
|
toLog = T.fromString
|
|
|
|
data Log :: Effect where
|
|
Log :: Severity -> T.Builder -> Log m ()
|
|
|
|
makeEffect ''Log
|
|
|
|
runLog ::
|
|
(Time :> es, Concurrent :> es, IOE :> es) =>
|
|
LogAction IO T.Builder ->
|
|
Eff (Log : es) a ->
|
|
Eff es a
|
|
runLog logger e = do
|
|
lock <- newQSem 1
|
|
runLogWithQsem lock logger e
|
|
|
|
runLogWithQsem ::
|
|
(Time :> es, Concurrent :> es, IOE :> es) =>
|
|
QSem ->
|
|
LogAction IO T.Builder ->
|
|
Eff (Log : es) a ->
|
|
Eff es a
|
|
runLogWithQsem lock logger e = do
|
|
reinterpret
|
|
(runReader lock)
|
|
( \_ -> \case
|
|
Log sev msg -> do
|
|
lock' <- ask
|
|
bracket_ (waitQSem lock') (signalQSem lock') $ do
|
|
t <- 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)
|
|
|
|
fmtMessage :: WithSeverity T.Builder -> T.Builder
|
|
fmtMessage (WithSeverity txt sev) = "[" <> T.fromText (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
|
|
|
|
--- Helpers
|
|
tshow :: Show a => a -> Text
|
|
tshow = T.pack . show
|