Logging.hs

{-# LANGUAGE PackageImports        #-}

module Language.PureScript.Ide.Logging
       ( runLogger
       , logPerf
       , displayTimeSpec
       , labelTimespec
       ) where

import Protolude

import "monad-logger" Control.Monad.Logger (LogLevel(..), LoggingT, MonadLogger, filterLogger, logOtherN, runStdoutLoggingT)
import Data.Text qualified as T
import Language.PureScript.Ide.Types (IdeLogLevel(..))
import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs)
import Text.Printf (printf)

runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a
runLogger logLevel' =
  runStdoutLoggingT . filterLogger (\_ logLevel ->
                                       case logLevel' of
                                         LogAll -> True
                                         LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)
                                         LogNone -> False
                                         LogDebug -> logLevel /= LevelOther "perf"
                                         LogPerf -> logLevel == LevelOther "perf")

labelTimespec :: Text -> TimeSpec -> Text
labelTimespec label duration = label <> ": " <> displayTimeSpec duration

logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t
logPerf format f = do
  start <- liftIO (getTime Monotonic)
  result <- f
  end <- liftIO (getTime Monotonic)
  logOtherN (LevelOther "perf") (format (diffTimeSpec start end))
  pure result

displayTimeSpec :: TimeSpec -> Text
displayTimeSpec ts =
  T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms"