Skip to content

Remove HsLogger #3526

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Mar 18, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 3 additions & 3 deletions exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -51,7 +51,7 @@ main :: IO ()
main = do
-- plugin cli commands use stderr logger for now unless we change the args
-- parser to get logging arguments first or do more complicated things
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder))

(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
Expand All @@ -71,7 +71,7 @@ main = do
in (argsTesting, minPriority, argsLogFile)
_ -> (False, Info, Nothing)

withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do
withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do
let
recorder = cmapWithPrio (pretty &&& id) $ mconcat
[textWithPriorityRecorder
Expand All @@ -87,7 +87,7 @@ main = do
-- ability of lsp-test to detect a stuck server in tests and benchmarks
& if argsTesting then cfilter (not . heapStats . snd . payload) else id
]
plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder))
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder)

defaultMain
(cmapWithPrio LogIdeMain recorder)
Expand Down
6 changes: 2 additions & 4 deletions exe/Wrapper.hs
Original file line number Diff line number Diff line change
Expand Up @@ -45,12 +45,10 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T
import Development.IDE.LSP.LanguageServer (runLanguageServer)
import qualified Development.IDE.Main as Main
import Development.IDE.Types.Logger (Logger (Logger),
import Development.IDE.Types.Logger (Doc, Logger (Logger),
Pretty (pretty),
Priority (Info),
Recorder (logger_),
WithPriority (WithPriority),
Doc,
cmapWithPrio,
makeDefaultStderrRecorder,
toCologActionWithPrio)
Expand All @@ -76,7 +74,7 @@ main = do
args <- getArguments "haskell-language-server-wrapper" mempty

hlsVer <- haskellLanguageServerVersion
recorder <- makeDefaultStderrRecorder Nothing Info
recorder <- makeDefaultStderrRecorder Nothing
case args of
ProbeToolsMode -> do
programsOfInterest <- findProgramVersions
Expand Down
4 changes: 2 additions & 2 deletions ghcide/exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -77,7 +77,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
-- stderr recorder just for plugin cli commands
pluginCliRecorder <-
cmapWithPrio pretty
<$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info
<$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])

let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))
-- WARNING: If you write to stdout before runLanguageServer
Expand All @@ -94,7 +94,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do

let minPriority = if argsVerbose then Debug else Info

docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority
docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])

(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
Expand Down
1 change: 0 additions & 1 deletion ghcide/ghcide.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -91,7 +91,6 @@ library
transformers,
unordered-containers >= 0.2.10.0,
vector,
hslogger,
Diff ^>=0.4.0,
vector,
opentelemetry >=0.6.1,
Expand Down
75 changes: 8 additions & 67 deletions ghcide/src/Development/IDE/Types/Logger.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,6 @@ module Development.IDE.Types.Logger
, withDefaultRecorder
, makeDefaultStderrRecorder
, makeDefaultHandleRecorder
, priorityToHsLoggerPriority
, LoggingColumn(..)
, cmapWithPrio
, withBacklog
Expand All @@ -40,8 +39,7 @@ import Control.Concurrent.STM (atomically,
readTVarIO,
writeTBQueue, writeTVar)
import Control.Exception (IOException)
import Control.Monad (forM_, unless, when,
(>=>))
import Control.Monad (unless, when, (>=>))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Foldable (for_)
import Data.Functor.Contravariant (Contravariant (contramap))
Expand Down Expand Up @@ -77,12 +75,7 @@ import qualified Colog.Core as Colog
import System.IO (Handle,
IOMode (AppendMode),
hClose, hFlush,
hSetEncoding, openFile,
stderr, utf8)
import qualified System.Log.Formatter as HSL
import qualified System.Log.Handler as HSL
import qualified System.Log.Handler.Simple as HSL
import qualified System.Log.Logger as HsLogger
openFile, stderr)
import UnliftIO (MonadUnliftIO,
displayException,
finally, try)
Expand Down Expand Up @@ -171,31 +164,24 @@ textHandleRecorder handle =
Recorder
{ logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle }

-- | Priority is actually for hslogger compatibility
makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder columns minPriority = do
makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))
makeDefaultStderrRecorder columns = do
lock <- liftIO newLock
makeDefaultHandleRecorder columns minPriority lock stderr
makeDefaultHandleRecorder columns lock stderr

-- | If no path given then use stderr, otherwise use file.
-- Kinda complicated because we also need to setup `hslogger` for
-- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our
-- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can
-- be removed completely. See `setupHsLogger` comment.
withDefaultRecorder
:: MonadUnliftIO m
=> Maybe FilePath
-- ^ Log file path. `Nothing` uses stderr
-> Maybe [LoggingColumn]
-- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
-> Priority
-- ^ min priority for hslogger compatibility
-> (Recorder (WithPriority (Doc d)) -> m a)
-- ^ action given a recorder
-> m a
withDefaultRecorder path columns minPriority action = do
withDefaultRecorder path columns action = do
lock <- liftIO newLock
let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock
let makeHandleRecorder = makeDefaultHandleRecorder columns lock
case path of
Nothing -> do
recorder <- makeHandleRecorder stderr
Expand All @@ -217,65 +203,20 @@ makeDefaultHandleRecorder
:: MonadIO m
=> Maybe [LoggingColumn]
-- ^ built-in logging columns to display. Nothing uses the default
-> Priority
-- ^ min priority for hslogger compatibility
-> Lock
-- ^ lock to take when outputting to handle
-> Handle
-- ^ handle to output to
-> m (Recorder (WithPriority (Doc a)))
makeDefaultHandleRecorder columns minPriority lock handle = do
makeDefaultHandleRecorder columns lock handle = do
let Recorder{ logger_ } = textHandleRecorder handle
let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) }
let loggingColumns = fromMaybe defaultLoggingColumns columns
let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder
-- see `setupHsLogger` comment
liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority)
pure (cmap docToText textWithPriorityRecorder)
where
docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions)

priorityToHsLoggerPriority :: Priority -> HsLogger.Priority
priorityToHsLoggerPriority = \case
Debug -> HsLogger.DEBUG
Info -> HsLogger.INFO
Warning -> HsLogger.WARNING
Error -> HsLogger.ERROR

-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses
-- `hslogger` to output compilation logs. The easiest way to merge these logs
-- with our log output is to setup an `hslogger` that uses the same handle
-- and same lock as our loggers. That way the output from our loggers and
-- `hie-bios` don't interleave strangely.
-- It may be possible to have `hie-bios` use our logger by decorating the
-- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from
-- `HieBios.findCradle`, but I remember trying that and something not good
-- happened. I'd have to try it again to remember if that was a real issue.
-- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all
-- references to `hslogger` can be removed entirely.
setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO ()
setupHsLogger lock handle extraLogNames level = do
hSetEncoding handle utf8

logH <- HSL.streamHandler handle level

let logHandle = logH
{ HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s }
logFormatter = HSL.tfLogFormatter logDateFormat logFormat
logHandler = HSL.setFormatter logHandle logFormatter

HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle])
HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler]
HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level

-- Also route the additional log names to the same log
forM_ extraLogNames $ \logName -> do
HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler]
HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level
where
logFormat = "$time [$tid] $prio $loggername:\t$msg"
logDateFormat = "%Y-%m-%d %H:%M:%S%Q"

data LoggingColumn
= TimeColumn
| ThreadIdColumn
Expand Down
2 changes: 1 addition & 1 deletion ghcide/test/exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -200,7 +200,7 @@ waitForAllProgressDone = loop

main :: IO ()
main = do
docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug
docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])

let docWithFilteredPriorityRecorder@Recorder{ logger_ } =
docWithPriorityRecorder
Expand Down
1 change: 0 additions & 1 deletion haskell-language-server.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -510,7 +510,6 @@ executable haskell-language-server-wrapper
, ghcide
, gitrev
, haskell-language-server
, hslogger
, hie-bios
, hls-plugin-api
, lsp
Expand Down
2 changes: 1 addition & 1 deletion hls-test-utils/src/Test/Hls.hs
Original file line number Diff line number Diff line change
Expand Up @@ -240,7 +240,7 @@ pluginTestRecorder = do
-- See 'runSessionWithServer'' for details.
initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())
initialiseTestRecorder envVars = do
docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug
docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing
-- There are potentially multiple environment variables that enable this logger
definedEnvVars <- forM envVars (\var -> fromMaybe "0" <$> lookupEnv var)
let logStdErr = any (/= "0") definedEnvVars
Expand Down
1 change: 0 additions & 1 deletion plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -49,7 +49,6 @@ library
, hashable
, hlint < 3.6
, hls-plugin-api ^>=1.6
, hslogger
, lens
, lsp
, refact
Expand Down