|
|
|
|
@ -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
|
|
|
|
|
|